Replace tabs with spaces

Replace tabs with spaces

/** maximum X per block (used in dimensions for blocks and amount of shared memory */
#define SHARED_X ${SHARED_X}
/** maximum Y per block (used in dimensions for blocks and amount of shared memory */
#define SHARED_Y ${SHARED_Y}

/** kernel contains a for-loop in which the score is calculated. */
#define DIAGONAL SHARED_X + SHARED_Y

/** amount of blocks across the X axis */
#define XdivSHARED_X (X/SHARED_X)
/** amount of blocks across the Y axis */
#define YdivSHARED_Y (Y/SHARED_Y)

/** character used to fill the sequence if length < X */
#define FILL_CHARACTER '\0'
#define FILL_SCORE -1E10

/** Set init for affine gap matrices */
#define AFFINE_GAP_INIT -1E10f

/** this value is used to allocate enough memory to store the starting points */
#define MAXIMUM_NUMBER_STARTING_POINTS (NUMBER_SEQUENCES*NUMBER_TARGETS*1000)

/**** Other definitions ****/

/** bit mask to get the negative value of a float, or to keep it negative */
#define SIGN_BIT_MASK 0x80000000

/* Scorings matrix for each thread block */
typedef struct {
    float value[SHARED_X][SHARED_Y];
}  LocalMatrix;

/* Scorings matrix for each sequence alignment */
typedef struct {
    LocalMatrix matrix[XdivSHARED_X][YdivSHARED_Y];
} ScoringsMatrix;

/* Scorings matrix for entire application */
typedef struct {
    ScoringsMatrix metaMatrix[NUMBER_SEQUENCES][NUMBER_TARGETS];
} GlobalMatrix;

typedef struct {
    float value[XdivSHARED_X][YdivSHARED_Y];
} BlockMaxima;

typedef struct {
    BlockMaxima blockMaxima[NUMBER_SEQUENCES][NUMBER_TARGETS];
} GlobalMaxima;

typedef struct {
    unsigned char value[SHARED_X][SHARED_Y];
} LocalDirection;

typedef struct {
    LocalDirection localDirection[XdivSHARED_X][YdivSHARED_Y];
} Direction;

typedef struct {
    Direction direction[NUMBER_SEQUENCES][NUMBER_TARGETS];
} GlobalDirection;

typedef struct {
    unsigned int sequence;
    unsigned int target;
    unsigned int blockX;
    unsigned int blockY;
    unsigned int valueX;
    unsigned int valueY;
    float score;
    float maxScore;
    float posScore;
} StartingPoint;

typedef struct {
    StartingPoint startingPoint[MAXIMUM_NUMBER_STARTING_POINTS];
} StartingPoints;

__kernel void calculateScore(
        __global GlobalMatrix *matrix,
        unsigned int x,
        unsigned int y,
        unsigned int numberOfBlocks,
        __global char *sequences,
        __global char *targets,
        __global GlobalMaxima *globalMaxima,
        __global GlobalDirection *globalDirection) {

    /**
     * shared memory block for calculations. It requires
     * extra (+1 in both directions) space to hold
     * Neighboring cells
     */
    __local float s_matrix[SHARED_X+1][SHARED_Y+1];
    /**
     * shared memory block for storing the maximum value of each neighboring cell.
     * Careful: the s_maxima[SHARED_X][SHARED_Y] does not contain the maximum value
     * after the calculation loop! This value is determined at the end of this
     * function.
     */
    __local float s_maxima[SHARED_X][SHARED_Y];

    // calculate indices:
    //unsigned int yDIVnumSeq = (blockIdx.y/NUMBER_SEQUENCES);
    // 1 is in y-direction and 0 is in x-direction
    unsigned int blockx = x - get_group_id(1)/NUMBER_TARGETS;//yDIVnumSeq;
    unsigned int blocky = y + get_group_id(1)/NUMBER_TARGETS;//yDIVnumSeq;
    unsigned int tIDx = get_local_id(0);
    unsigned int tIDy = get_local_id(1);
    unsigned int bIDx = get_group_id(0);
    unsigned int bIDy = get_group_id(1)%NUMBER_TARGETS;///numberOfBlocks;
    unsigned char direction = NO_DIRECTION;

    // indices of the current characters in both sequences.
    int seqIndex1 = tIDx + bIDx * X + blockx * SHARED_X;
    int seqIndex2 = tIDy + bIDy * Y + blocky * SHARED_Y;

    /* the next block is to get the maximum value from surrounding blocks. This maximum values is compared to the
     * first element in the shared score matrix s_matrix.
     */
    float maxPrev = 0.0f;
    if (!tIDx && !tIDy) {
        if (blockx && blocky) {
            maxPrev = fmax(fmax(globalMaxima->blockMaxima[bIDx][bIDy].value[blockx-1][blocky-1], globalMaxima->blockMaxima[bIDx][bIDy].value[blockx-1][blocky]), globalMaxima->blockMaxima[bIDx][bIDy].value[blockx][blocky-1]);
        }
        else if (blockx) {
            maxPrev = globalMaxima->blockMaxima[bIDx][bIDy].value[blockx-1][blocky];
        }
        else if (blocky) {
            maxPrev = globalMaxima->blockMaxima[bIDx][bIDy].value[blockx][blocky-1];
        }
    }
    // local scorings variables:
    float currentScore, ulS, lS, uS;
    float innerScore = 0.0f;
    /**
     * tXM1 and tYM1 are to store the current value of the thread Index. tIDx and tIDy are
     * both increased with 1 later on.
     */
    unsigned int tXM1 = tIDx;
    unsigned int tYM1 = tIDy;

    // shared location for the parts of the 2 sequences, for faster retrieval later on:
    __local char s_seq1[SHARED_X];
    __local char s_seq2[SHARED_Y];

    // copy sequence data to shared memory (shared is much faster than global)
    if (!tIDy)
        s_seq1[tIDx] = sequences[seqIndex1];
    if (!tIDx)
        s_seq2[tIDy] = targets[seqIndex2];

    // set both matrices to zero
    s_matrix[tIDx][tIDy] = 0.0f;
    s_maxima[tIDx][tIDy] = 0.0f;

    if (tIDx == SHARED_X-1  && ! tIDy)
        s_matrix[SHARED_X][0] = 0.0f;
    if (tIDy == SHARED_Y-1  && ! tIDx)
        s_matrix[0][SHARED_Y] = 0.0f;

    /**** sync barrier ****/
    s_matrix[tIDx][tIDy] = 0.0f;
    barrier(CLK_LOCAL_MEM_FENCE);

    // initialize outer parts of the matrix:
    if (!tIDx || !tIDy) {
        if (tIDx == SHARED_X-1)
            s_matrix[tIDx+1][tIDy] = 0.0f;
        if (tIDy == SHARED_Y-1)
            s_matrix[tIDx][tIDy+1] = 0.0f;
        if (blockx && !tIDx) {
            s_matrix[0][tIDy+1] = (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx-1][blocky].value[SHARED_X-1][tIDy];
        }
        if (blocky && !tIDy) {
            s_matrix[tIDx+1][0] = (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx][blocky-1].value[tIDx][SHARED_Y-1];
        }
        if (blockx && blocky && !tIDx && !tIDy){
            s_matrix[0][0] = (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx-1][blocky-1].value[SHARED_X-1][SHARED_Y-1];
        }
    }
    // set inner score (aka sequence match/mismatch score):
    char charS1 = s_seq1[tIDx];
    char charS2 = s_seq2[tIDy];

    innerScore = charS1 == FILL_CHARACTER || charS2 == FILL_CHARACTER ? FILL_SCORE : scoringsMatrix[charS1-characterOffset][charS2-characterOffset];

    // transpose the index
    ++tIDx;
    ++tIDy;
    // set shared matrix to zero (starting point!)
    s_matrix[tIDx][tIDy] = 0.0f;

    // wait until all elements have been copied to the shared memory block
    /**** sync barrier ****/
    barrier(CLK_LOCAL_MEM_FENCE);

    currentScore = 0.0f;

    for (int i=0; i < DIAGONAL; ++i) {
        if (i == tXM1+ tYM1) {
            // calculate only when there are two valid characters
            // this is necessary when the two sequences are not of equal length
            // this is the SW-scoring of the cell:

            ulS = s_matrix[tXM1][tYM1] + innerScore;
            lS = s_matrix[tXM1][tIDy] + gapScore;
            uS = s_matrix[tIDx][tYM1] + gapScore;

            if (currentScore < lS) { // score comes from left
                currentScore = lS;
                direction = LEFT_DIRECTION;
            }
            if (currentScore < uS) { // score comes from above
                currentScore = uS;
                direction = UPPER_DIRECTION;
            }
            if (currentScore < ulS) { // score comes from upper left
                currentScore = ulS;
                direction = UPPER_LEFT_DIRECTION;
            }
            s_matrix[tIDx][tIDy] = innerScore == FILL_SCORE ? 0.0 : currentScore; // copy score to matrix
        }

        else if (i-1 == tXM1 + tYM1 ){
            // use this to find fmax
            if (i==1) {
                s_maxima[0][0] = fmax(maxPrev, currentScore);
            }
            else if (!tXM1 && tYM1) {
                s_maxima[0][tYM1] = fmax(s_maxima[0][tYM1-1], currentScore);
            }
            else if (!tYM1 && tXM1) {
                s_maxima[tXM1][0] = fmax(s_maxima[tXM1-1][0], currentScore);
            }
            else if (tXM1 && tYM1 ){
                s_maxima[tXM1][tYM1] = fmax(s_maxima[tXM1-1][tYM1], fmax(s_maxima[tXM1][tYM1-1], currentScore));
            }
        }
        // wait until all threads have calculated their new score
        /**** sync barrier ****/
        barrier(CLK_LOCAL_MEM_FENCE);
    }
    // copy end score to the scorings matrix:
    (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx][blocky].value[tXM1][tYM1] = s_matrix[tIDx][tIDy];
    (*globalDirection).direction[bIDx][bIDy].localDirection[blockx][blocky].value[tXM1][tYM1] = direction;

    if (tIDx==SHARED_X && tIDy==SHARED_Y)
        globalMaxima->blockMaxima[bIDx][bIDy].value[blockx][blocky] = fmax(currentScore, fmax(s_maxima[SHARED_X-2][SHARED_Y-1], s_maxima[SHARED_X-1][SHARED_Y-2]));

    // wait until all threads have copied their score:
    /**** sync barrier ****/
    barrier(CLK_LOCAL_MEM_FENCE);
}

__kernel void calculateScoreAffineGap(
        __global GlobalMatrix *matrix,
        __global GlobalMatrix *matrix_i,
        __global GlobalMatrix *matrix_j,
        unsigned int x,
        unsigned int y,
        unsigned int numberOfBlocks,
        __global char *sequences,
        __global char *targets,
        __global GlobalMaxima *globalMaxima,
        __global GlobalDirection *globalDirection) {

    /**
     * shared memory block for calculations. It requires
     * extra (+1 in both directions) space to hold
     * Neighboring cells
     */
    __local float s_matrix[SHARED_X+1][SHARED_Y+1];
    __local float s_matrix_i[SHARED_X+1][SHARED_Y+1];
    __local float s_matrix_j[SHARED_X+1][SHARED_Y+1];
    /**
     * shared memory block for storing the maximum value of each neighboring cell.
     * Careful: the s_maxima[SHARED_X][SHARED_Y] does not contain the maximum value
     * after the calculation loop! This value is determined at the end of this
     * function.
     */
    __local float s_maxima[SHARED_X][SHARED_Y];

    // calculate indices:
    //unsigned int yDIVnumSeq = (blockIdx.y/NUMBER_SEQUENCES);
    // 1 is in y-direction and 0 is in x-direction
    unsigned int blockx = x - get_group_id(1)/NUMBER_TARGETS;//yDIVnumSeq;
    unsigned int blocky = y + get_group_id(1)/NUMBER_TARGETS;//yDIVnumSeq;
    unsigned int tIDx = get_local_id(0);
    unsigned int tIDy = get_local_id(1);
    unsigned int bIDx = get_group_id(0);
    unsigned int bIDy = get_group_id(1)%NUMBER_TARGETS;///numberOfBlocks;
    unsigned char direction = NO_DIRECTION;
    unsigned char direction_i = NO_DIRECTION;
    unsigned char direction_j = NO_DIRECTION;

    // indices of the current characters in both sequences.
    int seqIndex1 = tIDx + bIDx * X + blockx * SHARED_X;
    int seqIndex2 = tIDy + bIDy * Y + blocky * SHARED_Y;

    /* the next block is to get the maximum value from surrounding blocks. This maximum values is compared to the
     * first element in the shared score matrix s_matrix.
     */
    float maxPrev = 0.0f;
    if (!tIDx && !tIDy) {
        if (blockx && blocky) {
            maxPrev = fmax(fmax(globalMaxima->blockMaxima[bIDx][bIDy].value[blockx-1][blocky-1], globalMaxima->blockMaxima[bIDx][bIDy].value[blockx-1][blocky]), globalMaxima->blockMaxima[bIDx][bIDy].value[blockx][blocky-1]);
        }
        else if (blockx) {
            maxPrev = globalMaxima->blockMaxima[bIDx][bIDy].value[blockx-1][blocky];
        }
        else if (blocky) {
            maxPrev = globalMaxima->blockMaxima[bIDx][bIDy].value[blockx][blocky-1];
        }
    }
    // local scorings variables:
    float currentScore,currentScore_i, currentScore_j, m_M, m_I, m_J;
    float innerScore = 0.0f;
    /**
     * tXM1 and tYM1 are to store the current value of the thread Index. tIDx and tIDy are
     * both increased with 1 later on.
     */
    unsigned int tXM1 = tIDx;
    unsigned int tYM1 = tIDy;

    // shared location for the parts of the 2 sequences, for faster retrieval later on:
    __local char s_seq1[SHARED_X];
    __local char s_seq2[SHARED_Y];

    // copy sequence data to shared memory (shared is much faster than global)
    if (!tIDy)
        s_seq1[tIDx] = sequences[seqIndex1];
    if (!tIDx)
        s_seq2[tIDy] = targets[seqIndex2];

    // init matrices
    s_matrix[tIDx][tIDy] = 0.0f;
    s_matrix_i[tIDx][tIDy] = AFFINE_GAP_INIT;
    s_matrix_j[tIDx][tIDy] = AFFINE_GAP_INIT;
    s_maxima[tIDx][tIDy] = 0.0f;

    if (tIDx == SHARED_X-1  && ! tIDy){
        s_matrix[SHARED_X][0] = 0.0f;
        s_matrix_i[SHARED_X][0] = AFFINE_GAP_INIT;
        s_matrix_j[SHARED_X][0] = AFFINE_GAP_INIT;
    }
    if (tIDy == SHARED_Y-1  && ! tIDx) {
        s_matrix[0][SHARED_Y] = 0.0f;
        s_matrix_i[0][SHARED_Y] = AFFINE_GAP_INIT;
        s_matrix_j[0][SHARED_Y] = AFFINE_GAP_INIT;
    }

    /**** sync barrier ****/
    s_matrix[tIDx][tIDy] = 0.0f;
    barrier(CLK_LOCAL_MEM_FENCE);

    // initialize outer parts of the matrix:
    if (!tIDx || !tIDy) {
        if (tIDx == SHARED_X-1) {
            s_matrix[tIDx+1][tIDy] = 0.0f;
            s_matrix_i[tIDx+1][tIDy] = AFFINE_GAP_INIT;
            s_matrix_j[tIDx+1][tIDy] = AFFINE_GAP_INIT;
        }
        if (tIDy == SHARED_Y-1) {
            s_matrix[tIDx][tIDy+1] = 0.0f;
            s_matrix_i[tIDx][tIDy+1] = AFFINE_GAP_INIT;
            s_matrix_j[tIDx][tIDy+1] = AFFINE_GAP_INIT;
        }
        if (blockx && !tIDx) {
            s_matrix[0][tIDy+1] = (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx-1][blocky].value[SHARED_X-1][tIDy];
            s_matrix_i[0][tIDy+1] = (*matrix_i).metaMatrix[bIDx][bIDy].matrix[blockx-1][blocky].value[SHARED_X-1][tIDy];
            s_matrix_j[0][tIDy+1] = (*matrix_j).metaMatrix[bIDx][bIDy].matrix[blockx-1][blocky].value[SHARED_X-1][tIDy];
        }
        if (blocky && !tIDy) {
            s_matrix[tIDx+1][0] = (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx][blocky-1].value[tIDx][SHARED_Y-1];
            s_matrix_i[tIDx+1][0] = (*matrix_i).metaMatrix[bIDx][bIDy].matrix[blockx][blocky-1].value[tIDx][SHARED_Y-1];
            s_matrix_j[tIDx+1][0] = (*matrix_j).metaMatrix[bIDx][bIDy].matrix[blockx][blocky-1].value[tIDx][SHARED_Y-1];
        }
        if (blockx && blocky && !tIDx && !tIDy){
            s_matrix[0][0] = (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx-1][blocky-1].value[SHARED_X-1][SHARED_Y-1];
            s_matrix_i[0][0] = (*matrix_i).metaMatrix[bIDx][bIDy].matrix[blockx-1][blocky-1].value[SHARED_X-1][SHARED_Y-1];
            s_matrix_j[0][0] = (*matrix_j).metaMatrix[bIDx][bIDy].matrix[blockx-1][blocky-1].value[SHARED_X-1][SHARED_Y-1];
        }
    }
    // set inner score (aka sequence match/mismatch score):
    char charS1 = s_seq1[tIDx];
    char charS2 = s_seq2[tIDy];

    innerScore = charS1 == FILL_CHARACTER || charS2 == FILL_CHARACTER ? FILL_SCORE : scoringsMatrix[charS1-characterOffset][charS2-characterOffset];

    // transpose the index
    ++tIDx;
    ++tIDy;
    // set shared matrix to zero (starting point!)
    s_matrix[tIDx][tIDy] = 0.0f;
    s_matrix_i[tIDx][tIDy] = AFFINE_GAP_INIT;
    s_matrix_j[tIDx][tIDy] = AFFINE_GAP_INIT;

    // wait until all elements have been copied to the shared memory block
    /**** sync barrier ****/
    barrier(CLK_LOCAL_MEM_FENCE);

    for (int i=0; i < DIAGONAL; ++i) {
        if (i == tXM1+ tYM1) {
            currentScore = 0.0f;
            m_M = s_matrix[tXM1][tYM1]+innerScore;
            m_I = s_matrix_i[tXM1][tYM1]+innerScore;
            m_J = s_matrix_j[tXM1][tYM1]+innerScore;

            if (currentScore < m_I) { // score comes from I matrix (gap in x)
                currentScore = m_I;
                direction = A_DIRECTION | MAIN_MATRIX;
            }
            if (currentScore < m_J) { // score comes from J matrix (gap in y)
                currentScore = m_J;
                direction = A_DIRECTION | MAIN_MATRIX;
            }
            if (currentScore < m_M) { // score comes from m matrix (match)
                currentScore = m_M;
                direction = A_DIRECTION | MAIN_MATRIX;
            }
            s_matrix[tIDx][tIDy] = innerScore == FILL_SCORE ? 0.0 : currentScore; // copy score to matrix

            // now do I matrix:
            currentScore_i = AFFINE_GAP_INIT;
            m_M = gapScore + gapExtension + s_matrix[tIDx][tYM1];
            m_I = gapExtension + s_matrix_i[tIDx][tYM1];

            if (currentScore_i < m_I) { // score comes from I matrix (gap in x)
                currentScore_i = m_I;
                direction_i = B_DIRECTION | I_MATRIX;
            }
            if (currentScore_i < m_M) { // score comes from m matrix (match)
                currentScore_i = m_M;
                direction_i= B_DIRECTION | I_MATRIX;
            }
            s_matrix_i[tIDx][tIDy] = currentScore_i < 0 ? AFFINE_GAP_INIT : currentScore_i; // copy score to matrix

            // now do J matrix:
            currentScore_j = AFFINE_GAP_INIT;
            m_M = gapScore + gapExtension + s_matrix[tXM1][tIDy];
            m_J = gapExtension + s_matrix_j[tXM1][tIDy];

            if (currentScore_j < m_J) { // score comes from J matrix (gap in y)
                currentScore_j = m_J;
                direction_j = C_DIRECTION | J_MATRIX;
            }
            if (currentScore_j < m_M) { // score comes from m matrix (match)
                currentScore_j = m_M;
                direction_j = C_DIRECTION | J_MATRIX;
            }
            s_matrix_j[tIDx][tIDy] = currentScore_j < 0 ? AFFINE_GAP_INIT : currentScore_j; // copy score to matrix

            currentScore = fmax(currentScore,fmax(currentScore_i,currentScore_j));
            if (currentScore > 0) {
                if (currentScore == s_matrix[tIDx][tIDy]) {// direction from main
                    direction = direction;
                }
                else if(currentScore == s_matrix_i[tIDx][tIDy]) {// direction from I
                    direction = direction_i;
                }
                else if(currentScore == s_matrix_j[tIDx][tIDy]){ // direction from J
                    direction = direction_j;
                }
            }
        }

        else if (i-1 == tXM1 + tYM1 ){
            // use this to find fmax
            if (i==1) {
                s_maxima[0][0] = fmax(maxPrev, currentScore);
            }
            else if (!tXM1 && tYM1) {
                s_maxima[0][tYM1] = fmax(s_maxima[0][tYM1-1], currentScore);
            }
            else if (!tYM1 && tXM1) {
                s_maxima[tXM1][0] = fmax(s_maxima[tXM1-1][0], currentScore);
            }
            else if (tXM1 && tYM1 ){
                s_maxima[tXM1][tYM1] = fmax(s_maxima[tXM1-1][tYM1], fmax(s_maxima[tXM1][tYM1-1], currentScore));
            }
        }
        // wait until all threads have calculated their new score
        /**** sync barrier ****/
        barrier(CLK_LOCAL_MEM_FENCE);
    }
    // copy end score to the scorings matrix:
    (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx][blocky].value[tXM1][tYM1] = s_matrix[tIDx][tIDy];
    (*matrix_i).metaMatrix[bIDx][bIDy].matrix[blockx][blocky].value[tXM1][tYM1] = s_matrix_i[tIDx][tIDy];
    (*matrix_j).metaMatrix[bIDx][bIDy].matrix[blockx][blocky].value[tXM1][tYM1] = s_matrix_j[tIDx][tIDy];
    (*globalDirection).direction[bIDx][bIDy].localDirection[blockx][blocky].value[tXM1][tYM1] = direction;

    if (tIDx==SHARED_X && tIDy==SHARED_Y)
        globalMaxima->blockMaxima[bIDx][bIDy].value[blockx][blocky] = fmax(currentScore, fmax(s_maxima[SHARED_X-2][SHARED_Y-1], s_maxima[SHARED_X-1][SHARED_Y-2]));

    // wait until all threads have copied their score:
    /**** sync barrier ****/
    barrier(CLK_LOCAL_MEM_FENCE);
}

__kernel void traceback(
        __global GlobalMatrix *matrix,
        unsigned int x,
        unsigned int y,
        unsigned int numberOfBlocks,
        __global GlobalMaxima *globalMaxima,
        __global GlobalDirection *globalDirection,
        volatile __global unsigned int *indexIncrement,
        __global StartingPoints *startingPoints,
        __global float *maxPossibleScore) {

    /**
     * shared memory block for calculations. It requires
     * extra (+1 in both directions) space to hold
     * Neighboring cells
     */
    __local float s_matrix[SHARED_X+1][SHARED_Y+1];
    /**
     * shared memory for storing the maximum value of this alignment.
     */
    __local float s_maxima[1];
    __local float s_maxPossibleScore[1];

    // calculate indices:
    unsigned int yDIVnumSeq = (get_group_id(1)/NUMBER_TARGETS);
    unsigned int blockx = x - yDIVnumSeq;
    unsigned int blocky = y + yDIVnumSeq;
    unsigned int tIDx = get_local_id(0);
    unsigned int tIDy = get_local_id(1);
    unsigned int bIDx = get_group_id(0);
    unsigned int bIDy = get_group_id(1)%NUMBER_TARGETS;

    float value = 0.0;

    if (!tIDx && !tIDy) {
        s_maxima[0] = globalMaxima->blockMaxima[bIDx][bIDy].value[XdivSHARED_X-1][YdivSHARED_Y-1];
        s_maxPossibleScore[0] = maxPossibleScore[bIDy*NUMBER_SEQUENCES+bIDx];
    }

    barrier(CLK_LOCAL_MEM_FENCE);
    if (s_maxima[0]>= MINIMUM_SCORE) { // if the maximum score is below threshold, there is nothing to do

        s_matrix[tIDx][tIDy] = (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx][blocky].value[tIDx][tIDy];

        unsigned char direction = globalDirection->direction[bIDx][bIDy].localDirection[blockx][blocky].value[tIDx][tIDy];

        // wait until all elements have been copied to the shared memory block
        /**** sync barrier ****/
        barrier(CLK_LOCAL_MEM_FENCE);

        for (int i=DIAGONAL-1; i >= 0; --i) {

            if ((i == tIDx + tIDy) && direction == UPPER_LEFT_DIRECTION && s_matrix[tIDx][tIDy] >= LOWER_LIMIT_SCORE * s_maxima[0] && s_matrix[tIDx][tIDy] >= s_maxPossibleScore[0]) {
                // found starting point!
                // reserve index:
                unsigned int index = atom_inc(&indexIncrement[0]);
                StartingPoint start;
                //__global StartingPoint *start = &(startingPoints->startingPoint[index]);
                start.sequence = bIDx;
                start.target = bIDy;
                start.blockX = blockx;
                start.blockY = blocky;
                start.valueX = tIDx;
                start.valueY = tIDy;
                start.score = s_matrix[tIDx][tIDy];
                start.maxScore = s_maxima[0];
                start.posScore = s_maxPossibleScore[0];
                startingPoints->startingPoint[index] = start;
                // mark this value:
                s_matrix[tIDx][tIDy] = as_float(SIGN_BIT_MASK | as_int(s_matrix[tIDx][tIDy]));

            }

            barrier(CLK_LOCAL_MEM_FENCE);

            if ((i == tIDx + tIDy) && s_matrix[tIDx][tIDy] < 0 && direction == UPPER_LEFT_DIRECTION) {
                if (tIDx && tIDy){
                    value = s_matrix[tIDx-1][tIDy-1];
                    if (value == 0.0f) {
                        direction = STOP_DIRECTION;
                    }
                    else {
                        s_matrix[tIDx-1][tIDy-1] = as_float(SIGN_BIT_MASK | as_int(value));
                    }

                }
                else if (!tIDx && tIDy && blockx) {
                    value = (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx-1][blocky].value[SHARED_X-1][tIDy-1];
                    if (value == 0.0f) {
                        direction = STOP_DIRECTION;
                    }
                    else {
                        (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx-1][blocky].value[SHARED_X-1][tIDy-1] = as_float(SIGN_BIT_MASK | as_int(value));
                    }

                }
                else if (!tIDx && !tIDy && blockx && blocky) {
                    value = (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx-1][blocky-1].value[SHARED_X-1][SHARED_Y-1];
                    if (value == 0.0f) {
                        direction = STOP_DIRECTION;
                    }
                    else {
                          (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx-1][blocky-1].value[SHARED_X-1][SHARED_Y-1] = as_float(SIGN_BIT_MASK | as_int(value));
                    }

                }
                else if (tIDx && !tIDy && blocky) {
                    value = (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx][blocky-1].value[tIDx-1][SHARED_Y-1];
                    if (value == 0.0f) {
                        direction = STOP_DIRECTION;
                    }
                    else {
                        (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx][blocky-1].value[tIDx-1][SHARED_Y-1] = as_float(SIGN_BIT_MASK | as_int(value));
                    }

                }
            }
            barrier(CLK_LOCAL_MEM_FENCE);

            if ((i == tIDx + tIDy) && s_matrix[tIDx][tIDy] < 0 && direction == UPPER_DIRECTION) {
                if (!tIDy) {
                    if (blocky) {
                        value = (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx][blocky-1].value[tIDx][SHARED_Y-1];
                        if (value == 0.0f) {
                            direction = STOP_DIRECTION;
                        }
                        else {
                            (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx][blocky-1].value[tIDx][SHARED_Y-1] = as_float(SIGN_BIT_MASK | as_int(value));
                        }

                    }
                }
                else {
                    value = s_matrix[tIDx][tIDy-1];
                    if (value == 0.0f) {
                        direction = STOP_DIRECTION;
                    }
                    else {
                        s_matrix[tIDx][tIDy-1] = as_float(SIGN_BIT_MASK | as_int(value));
                    }

                }
            }

            barrier(CLK_LOCAL_MEM_FENCE);
            if ((i == tIDx + tIDy) && s_matrix[tIDx][tIDy] < 0 && direction == LEFT_DIRECTION) {
                if (!tIDx){
                    if (blockx) {
                        value = (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx-1][blocky].value[SHARED_X-1][tIDy];
                        if (value == 0.0f) {
                            direction = STOP_DIRECTION;
                        }
                        else {
                            (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx-1][blocky].value[SHARED_X-1][tIDy] = as_float(SIGN_BIT_MASK | as_int(value));
                        }

                    }
                }
                else {
                    value = s_matrix[tIDx-1][tIDy];
                    if (value == 0.0f) {
                        direction = STOP_DIRECTION;
                    }
                    else {
                        s_matrix[tIDx-1][tIDy] = as_float(SIGN_BIT_MASK | as_int(value));
                    }

                }
            }

            barrier(CLK_LOCAL_MEM_FENCE);

        }

        // copy end score to the scorings matrix:
        if (s_matrix[tIDx][tIDy] < 0) {
            (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx][blocky].value[tIDx][tIDy] = s_matrix[tIDx][tIDy];
            globalDirection->direction[bIDx][bIDy].localDirection[blockx][blocky].value[tIDx][tIDy] = direction;
        }
        /**** sync barrier ****/
        barrier(CLK_LOCAL_MEM_FENCE);
    }
}

__kernel void tracebackAffineGap(
        __global GlobalMatrix *matrix,
        __global GlobalMatrix *matrix_i,
        __global GlobalMatrix *matrix_j,
        unsigned int x,
        unsigned int y,
        unsigned int numberOfBlocks,
        __global GlobalMaxima *globalMaxima,
        __global GlobalDirection *globalDirection,
        volatile __global unsigned int *indexIncrement,
        __global StartingPoints *startingPoints,
        __global float *maxPossibleScore) {

    /**
     * shared memory block for calculations. It requires
     * extra (+1 in both directions) space to hold
     * Neighboring cells
     */
    __local float s_matrix[SHARED_X+1][SHARED_Y+1];
    __local float s_matrix_i[SHARED_X+1][SHARED_Y+1];
    __local float s_matrix_j[SHARED_X+1][SHARED_Y+1];
    /**
     * shared memory for storing the maximum value of this alignment.
     */
    __local float s_maxima[1];
    __local float s_maxPossibleScore[1];

    // calculate indices:
    unsigned int yDIVnumSeq = (get_group_id(1)/NUMBER_TARGETS);
    unsigned int blockx = x - yDIVnumSeq;
    unsigned int blocky = y + yDIVnumSeq;
    unsigned int tIDx = get_local_id(0);
    unsigned int tIDy = get_local_id(1);
    unsigned int bIDx = get_group_id(0);
    unsigned int bIDy = get_group_id(1)%NUMBER_TARGETS;

    float value = 0.0;

    if (!tIDx && !tIDy) {
        s_maxima[0] = globalMaxima->blockMaxima[bIDx][bIDy].value[XdivSHARED_X-1][YdivSHARED_Y-1];
        s_maxPossibleScore[0] = maxPossibleScore[bIDy*NUMBER_SEQUENCES+bIDx];
    }

    barrier(CLK_LOCAL_MEM_FENCE);
    if (s_maxima[0]>= MINIMUM_SCORE) { // if the maximum score is below threshold, there is nothing to do
        unsigned char direction = DIRECTION_MASK & globalDirection->direction[bIDx][bIDy].localDirection[blockx][blocky].value[tIDx][tIDy];
        unsigned char matrix_source = MATRIX_MASK & globalDirection->direction[bIDx][bIDy].localDirection[blockx][blocky].value[tIDx][tIDy];

        s_matrix[tIDx][tIDy] = (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx][blocky].value[tIDx][tIDy];
        s_matrix_i[tIDx][tIDy] = (*matrix_i).metaMatrix[bIDx][bIDy].matrix[blockx][blocky].value[tIDx][tIDy];
        s_matrix_j[tIDx][tIDy] = (*matrix_j).metaMatrix[bIDx][bIDy].matrix[blockx][blocky].value[tIDx][tIDy];

        // wait until all elements have been copied to the shared memory block
        /**** sync barrier ****/
        barrier(CLK_LOCAL_MEM_FENCE);

        for (int i=DIAGONAL-1; i >= 0; --i) {

            if ((i == tIDx + tIDy) && matrix_source == MAIN_MATRIX && s_matrix[tIDx][tIDy] >= LOWER_LIMIT_SCORE * s_maxima[0] && s_matrix[tIDx][tIDy] >= s_maxPossibleScore[0]) {
                // found starting point!
                // reserve index:
                unsigned int index = atom_inc(&indexIncrement[0]);
                StartingPoint start;
                //__global StartingPoint *start = &(startingPoints->startingPoint[index]);
                start.sequence = bIDx;
                start.target = bIDy;
                start.blockX = blockx;
                start.blockY = blocky;
                start.valueX = tIDx;
                start.valueY = tIDy;
                start.score = s_matrix[tIDx][tIDy];
                start.maxScore = s_maxima[0];
                start.posScore = s_maxPossibleScore[0];
                startingPoints->startingPoint[index] = start;
                // mark this value:
                s_matrix[tIDx][tIDy] = as_float(SIGN_BIT_MASK | as_int(s_matrix[tIDx][tIDy]));

            }

            barrier(CLK_LOCAL_MEM_FENCE);

            if ((i == tIDx + tIDy) && (
                    (s_matrix[tIDx][tIDy] < 0 && matrix_source == MAIN_MATRIX) ||
                    (s_matrix_i[tIDx][tIDy] < 0 && s_matrix_i[tIDx][tIDy] > AFFINE_GAP_INIT && matrix_source == I_MATRIX) ||
                    (s_matrix_j[tIDx][tIDy] < 0 && s_matrix_j[tIDx][tIDy] > AFFINE_GAP_INIT && matrix_source == J_MATRIX)
                    )) {
                    // check which matrix to go to:
                    switch (direction) {
                    case A_DIRECTION : // M
                        if (tIDx && tIDy){
                            value = s_matrix[tIDx-1][tIDy-1];
                            if (value == 0.0f)
                                direction = STOP_DIRECTION;
                            else
                                s_matrix[tIDx-1][tIDy-1] = as_float(SIGN_BIT_MASK | as_int(value));
                        }
                        else if (!tIDx && tIDy && blockx) {
                            value = (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx-1][blocky].value[SHARED_X-1][tIDy-1];
                            if (value == 0.0f)
                                direction = STOP_DIRECTION;
                            else
                                (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx-1][blocky].value[SHARED_X-1][tIDy-1] = as_float(SIGN_BIT_MASK | as_int(value));
                        }
                        else if (!tIDx && !tIDy && blockx && blocky) {
                            value = (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx-1][blocky-1].value[SHARED_X-1][SHARED_Y-1];
                            if (value == 0.0f)
                                direction = STOP_DIRECTION;
                            else
                                (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx-1][blocky-1].value[SHARED_X-1][SHARED_Y-1] = as_float(SIGN_BIT_MASK | as_int(value));
                        }
                        else if (tIDx && !tIDy && blocky) {
                            value = (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx][blocky-1].value[tIDx-1][SHARED_Y-1];
                            if (value == 0.0f)
                                direction = STOP_DIRECTION;
                            else
                                (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx][blocky-1].value[tIDx-1][SHARED_Y-1] = as_float(SIGN_BIT_MASK | as_int(value));
                        }

//direction = tracebackStepLeftUp(blockx, blocky, s_matrix, matrix, direction);
                        break;
                    case B_DIRECTION : // I
                        if (!tIDy) {
                            if (blocky) {
                                value = (*matrix_i).metaMatrix[bIDx][bIDy].matrix[blockx][blocky-1].value[tIDx][SHARED_Y-1];
                                (*matrix_i).metaMatrix[bIDx][bIDy].matrix[blockx][blocky-1].value[tIDx][SHARED_Y-1] = as_float(SIGN_BIT_MASK | as_int(value));
                            }
                        }
                        else {
                            value = s_matrix_i[tIDx][tIDy-1];
                            s_matrix_i[tIDx][tIDy-1] = as_float(SIGN_BIT_MASK | as_int(value));
                        }

                        //direction = tracebackStepUp(blockx, blocky, s_matrix_i, matrix_i, direction);
                        break;
                    case C_DIRECTION : // J
                        if (!tIDx){
                            if (blockx) {
                                value = (*matrix_j).metaMatrix[bIDx][bIDy].matrix[blockx-1][blocky].value[SHARED_X-1][tIDy];
                                (*matrix_j).metaMatrix[bIDx][bIDy].matrix[blockx-1][blocky].value[SHARED_X-1][tIDy] = as_float(SIGN_BIT_MASK | as_int(value));
                            }
                        }
                        else {
                            value = s_matrix_j[tIDx-1][tIDy];
                            s_matrix_j[tIDx-1][tIDy] = as_float(SIGN_BIT_MASK | as_int(value));
                        }

                        //direction = tracebackStepLeft(blockx, blocky, s_matrix_j, matrix_j, direction);
                        break;
                    }
            }
            barrier(CLK_LOCAL_MEM_FENCE);
        }

        // copy end score to the scorings matrix:
        if (matrix_source == MAIN_MATRIX) {
            (*matrix).metaMatrix[bIDx][bIDy].matrix[blockx][blocky].value[tIDx][tIDy] = s_matrix[tIDx][tIDy];
            globalDirection->direction[bIDx][bIDy].localDirection[blockx][blocky].value[tIDx][tIDy] = direction;
        }
        else if (matrix_source == I_MATRIX) {
            (*matrix_i).metaMatrix[bIDx][bIDy].matrix[blockx][blocky].value[tIDx][tIDy] = s_matrix_i[tIDx][tIDy];
            globalDirection->direction[bIDx][bIDy].localDirection[blockx][blocky].value[tIDx][tIDy] = direction;
        }
        else if (matrix_source == J_MATRIX) {
            (*matrix_j).metaMatrix[bIDx][bIDy].matrix[blockx][blocky].value[tIDx][tIDy] = s_matrix_j[tIDx][tIDy];
            globalDirection->direction[bIDx][bIDy].localDirection[blockx][blocky].value[tIDx][tIDy] = direction;
        }
        /**** sync barrier ****/
        barrier(CLK_LOCAL_MEM_FENCE);
    }
}


r1679: Fix read-double-from-socket-bug

r1679: Fix read-double-from-socket-bug

;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          postgresql-socket.cl
;;;; Purpose:       Low-level PostgreSQL interface using sockets
;;;; Programmers:   Kevin M. Rosenberg based on
;;;;                Original code by Pierre R. Mai
;;;;
;;;; Date Started:  Feb 2002
;;;;
;;;; $Id: postgresql-socket-api.cl,v 1.10 2002/03/27 10:48:12 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.
;;;; *************************************************************************

;;;; Changes by Kevin Rosenberg
;;;;  - Added socket open functions for Allegro and Lispworks
;;;;  - Changed CMUCL FFI to UFFI
;;;;  - Added necessary (force-output) for socket streams on
;;;;     Allegro and Lispworks
;;;;  - Added initialization variable
;;;;  - Added field type processing

(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
(in-package :postgresql-socket)

(uffi:def-enum pgsql-ftype
    ((:bytea 17)
     (:int2 21)
     (:int4 23)
     (:int8 20)
     (:float4 700)
     (:float8 701)))

(defmethod database-type-library-loaded ((database-type
					  (eql :postgresql-socket)))
  "T if foreign library was able to be loaded successfully. Always true for
socket interface"
  t)

;;; Message I/O stuff

(defmacro define-message-constants (description &rest clauses)
  (assert (evenp (length clauses)))
  (loop with seen-characters = nil
	for (name char) on clauses by #'cddr
	for char-code = (char-code char)
	for doc-string = (format nil "~A (~:C): ~A" description char name)
	if (member char seen-characters)
	do (error "Duplicate message type ~@C for group ~A" char description)
	else
	collect
	`(defconstant ,name ,char-code ,doc-string)
	into result-clauses
	and do (push char seen-characters)
      finally
	(return `(progn ,@result-clauses))))

(eval-when (:compile-toplevel :load-toplevel :execute)
(define-message-constants "Backend Message Constants"
  +ascii-row-message+ #\D
  +authentication-message+ #\R
  +backend-key-message+ #\K
  +binary-row-message+ #\B
  +completed-response-message+ #\C
  +copy-in-response-message+ #\G
  +copy-out-response-message+ #\H
  +cursor-response-message+ #\P
  +empty-query-response-message+ #\I
  +error-response-message+ #\E
  +function-response-message+ #\V
  +notice-response-message+ #\N
  +notification-response-message+ #\A
  +ready-for-query-message+ #\Z
  +row-description-message+ #\T))

(defgeneric send-socket-value (type socket value))

(defmethod send-socket-value ((type (eql 'int32)) socket (value integer))
  (write-byte (ldb (byte 8 24) value) socket)
  (write-byte (ldb (byte 8 16) value) socket)
  (write-byte (ldb (byte 8 8) value) socket)
  (write-byte (ldb (byte 8 0) value) socket))

(defmethod send-socket-value ((type (eql 'int16)) socket (value integer))
  (write-byte (ldb (byte 8 8) value) socket)
  (write-byte (ldb (byte 8 0) value) socket))

(defmethod send-socket-value ((type (eql 'int8)) socket (value integer))
  (write-byte (ldb (byte 8 0) value) socket))

(defmethod send-socket-value ((type (eql 'string)) socket (value string))
  (loop for char across value
	for code = (char-code char)
	do (write-byte code socket)
	finally (write-byte 0 socket)))

(defmethod send-socket-value ((type (eql 'limstring)) socket (value string))
  (loop for char across value
	for code = (char-code char)
	do (write-byte code socket)))

(defmethod send-socket-value ((type (eql 'byte)) socket (value integer))
  (write-byte value socket))

(defmethod send-socket-value ((type (eql 'byte)) socket (value character))
  (write-byte (char-code value) socket))

(defmethod send-socket-value ((type (eql 'byte)) socket value)
  (write-sequence value socket))

(defgeneric read-socket-value (type socket))

(defmethod read-socket-value ((type (eql 'int32)) socket)
  (let ((result 0))
    (setf (ldb (byte 8 24) result) (read-byte socket))
    (setf (ldb (byte 8 16) result) (read-byte socket))
    (setf (ldb (byte 8 8) result) (read-byte socket))
    (setf (ldb (byte 8 0) result) (read-byte socket))
    result))

(defmethod read-socket-value ((type (eql 'int16)) socket)
  (let ((result 0))
    (setf (ldb (byte 8 8) result) (read-byte socket))
    (setf (ldb (byte 8 0) result) (read-byte socket))
    result))

(defmethod read-socket-value ((type (eql 'int8)) socket)
  (read-byte socket))

(defmethod read-socket-value ((type (eql 'string)) socket)
  (with-output-to-string (out)
    (loop for code = (read-byte socket)
	  until (zerop code)
	  do (write-char (code-char code) out))))

(defgeneric skip-socket-value (type socket))

(defmethod skip-socket-value ((type (eql 'int32)) socket)
  (dotimes (i 4) (read-byte socket)))

(defmethod skip-socket-value ((type (eql 'int16)) socket)
  (dotimes (i 2) (read-byte socket)))

(defmethod skip-socket-value ((type (eql 'int8)) socket)
  (read-byte socket))

(defmethod skip-socket-value ((type (eql 'string)) socket)
  (loop until (zerop (read-byte socket))))

(defmacro define-message-sender (name (&rest args) &rest clauses)
  (loop with socket-var = (gensym)
	for (type value) in clauses
	collect
	`(send-socket-value ',type ,socket-var ,value)
	into body
      finally
	(return
	  `(defun ,name (,socket-var ,@args)
	     ,@body))))

(defun pad-limstring (string limit)
  (let ((result (make-string limit :initial-element #\NULL)))
    (loop for char across string
	  for index from 0 below limit
	  do (setf (char result index) char))
    result))

(define-message-sender send-startup-message
    (database user &optional (command-line "") (backend-tty ""))
  (int32 296)                           ; Length
  (int32 #x00020000)                    ; Version 2.0
  (limstring (pad-limstring database 64))
  (limstring (pad-limstring user 32))
  (limstring (pad-limstring command-line 64))
  (limstring (pad-limstring "" 64))     ; Unused
  (limstring (pad-limstring backend-tty 64)))

(define-message-sender send-terminate-message ()
  (byte #\X))

(define-message-sender send-unencrypted-password-message (password)
  (int32 (+ 5 (length password)))
  (string password))

(define-message-sender send-query-message (query)
  (byte #\Q)
  (string query))

(define-message-sender send-encrypted-password-message (crypted-password)
  (int32 (+ 5 (length crypted-password)))
  (string crypted-password))

(define-message-sender send-cancel-request (pid key)
  (int32 16)                            ; Length
  (int32 80877102)                      ; Magic
  (int32 pid)
  (int32 key))

(defun read-socket-sequence (string stream)
"KMR -- Added to support reading from binary stream into a string"
  (declare (optimize (speed 3) (safety 0))
	   (string string))
  (dotimes (i (length string))
    (declare (fixnum i))
    (setf (char string i) (code-char (read-byte stream))))
  string)

;;; Support for encrypted password transmission

(defconstant +crypt-library+ "/usr/lib/libcrypt.so"
  "Name of the shared library to load in order to access the crypt
function named by `*crypt-function-name*'.")

(defvar *crypt-library-loaded* nil)

(defun crypt-password (password salt)
  "Encrypt a password for transmission to a PostgreSQL server."
  (unless *crypt-library-loaded*
    (uffi:load-foreign-library +crypt-library+ :supporting-libaries '("c"))
    (eval (uffi:def-function "crypt"
	      ((key :cstring)
	       (salt :cstring))
	    :returning :cstring))
    (setq *crypt-library-loaded* t))
   (uffi:with-cstring (password-cstring password)
     (uffi:with-cstring (salt-cstring salt)
       (uffi:convert-from-cstring (crypt password-cstring salt-cstring)))))
;;; Condition hierarchy

(define-condition postgresql-condition (condition)
  ((connection :initarg :connection :reader postgresql-condition-connection)
   (message :initarg :message :reader postgresql-condition-message))
  (:report
   (lambda (c stream)
     (format stream "~@<~A occurred on connection ~A. ~:@_Reason: ~A~:@>"
	     (type-of c)
	     (postgresql-condition-connection c)
	     (postgresql-condition-message c)))))

(define-condition postgresql-error (error postgresql-condition)
  ())

(define-condition postgresql-fatal-error (postgresql-error)
  ())

(define-condition postgresql-login-error (postgresql-fatal-error)
  ())

(define-condition postgresql-warning (warning postgresql-condition)
  ())

(define-condition postgresql-notification (postgresql-condition)
  ()
  (:report
   (lambda (c stream)
     (format stream "~@<Asynchronous notification on connection ~A: ~:@_~A~:@>"
	     (postgresql-condition-connection c)
	     (postgresql-condition-message c)))))

;;; Structures

(defstruct postgresql-connection
  host
  port
  database
  user
  password
  options
  tty
  socket
  pid
  key)

(defstruct postgresql-cursor
  connection
  name
  fields)

;;; Socket stuff

(defconstant +postgresql-server-default-port+ 5432
  "Default port of PostgreSQL server.")

(defvar *postgresql-server-socket-timeout* 60
  "Timeout in seconds for reads from the PostgreSQL server.")

#+cmu
(defun open-postgresql-socket (host port)
  (etypecase host
    (pathname
     ;; Directory to unix-domain socket
     (ext:connect-to-unix-socket
      (namestring
       (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
		      :defaults host))))
    (string
     (ext:connect-to-inet-socket host port))))

#+cmu
(defun open-postgresql-socket-stream (host port)
  (system:make-fd-stream
   (open-postgresql-socket host port)
   :input t :output t :element-type '(unsigned-byte 8)
   :buffering :none
   :timeout *postgresql-server-socket-timeout*))

#+allegro
(defun open-postgresql-socket-stream (host port)
  (etypecase host
    (pathname
     (let ((path (namestring
		  (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
				 :defaults host))))
       (socket:make-socket :type :stream :address-family :file
			   :connect :active
			   :remote-filename path :local-filename path)))
    (string
     (socket:with-pending-connect
	 (mp:with-timeout (*postgresql-server-socket-timeout* (error "connect failed"))
	   (socket:make-socket :type :stream :address-family :internet
			       :remote-port port :remote-host host
			       :connect :active :nodelay t))))
    ))

#+lispworks
(defun open-postgresql-socket-stream (host port)
  (etypecase host
    (pathname
     (error "File sockets not supported on Lispworks."))
    (string
     (comm:open-tcp-stream host port :direction :io :element-type '(unsigned-byte 8)
			   :read-timeout *postgresql-server-socket-timeout*))
    ))

;;; Interface Functions

(defun open-postgresql-connection (&key (host (cmucl-compat:required-argument))
					(port +postgresql-server-default-port+)
					(database (cmucl-compat:required-argument))
					(user (cmucl-compat:required-argument))
					options tty password)
  "Open a connection to a PostgreSQL server with the given parameters.
Note that host, database and user arguments must be supplied.

If host is a pathname, it is assumed to name a directory containing
the local unix-domain sockets of the server, with port selecting which
of those sockets to open.  If host is a string, it is assumed to be
the name of the host running the PostgreSQL server.  In that case a
TCP connection to the given port on that host is opened in order to
communicate with the server.  In either case the port argument
defaults to `+postgresql-server-default-port+'.

Password is the clear-text password to be passed in the authentication
phase to the server.  Depending on the server set-up, it is either
passed in the clear, or encrypted via crypt and a server-supplied
salt.  In that case the alien function specified by `*crypt-library*'
and `*crypt-function-name*' is used for encryption.

Note that all the arguments (including the clear-text password
argument) are stored in the `postgresql-connection' structure, in
order to facilitate automatic reconnection in case of communication
troubles."
  (reopen-postgresql-connection
   (make-postgresql-connection :host host :port port
			       :options (or options "") :tty (or tty "")
			       :database database :user user
			       :password (or password ""))))

(defun reopen-postgresql-connection (connection)
  "Reopen the given PostgreSQL connection.  Closes any existing
connection, if it is still open."
  (when (postgresql-connection-open-p connection)
    (close-postgresql-connection connection))
  (let ((socket (open-postgresql-socket-stream
		  (postgresql-connection-host connection)
		  (postgresql-connection-port connection))))
    (unwind-protect
	 (progn
	   (setf (postgresql-connection-socket connection) socket)
	   (send-startup-message socket
				 (postgresql-connection-database connection)
				 (postgresql-connection-user connection)
				 (postgresql-connection-options connection)
				 (postgresql-connection-tty connection))
	   (force-output socket)
	   (loop
	       (case (read-socket-value 'int8 socket)
		 (#.+authentication-message+
		  (case (read-socket-value 'int32 socket)
		    (0 (return))
		    ((1 2)
		     (error 'postgresql-login-error
			    :connection connection
			    :message
			    "Postmaster expects unsupported Kerberos authentication."))
		    (3
		     (send-unencrypted-password-message
		      socket
		      (postgresql-connection-password connection)))
		    (4
		     (let ((salt (make-string 2)))
		       (read-socket-sequence salt socket)
		       (send-encrypted-password-message
			socket
			(crypt-password
			 (postgresql-connection-password connection) salt))))
		    (t
		     (error 'postgresql-login-error
			    :connection connection
			    :message
			    "Postmaster expects unknown authentication method."))))
		 (#.+error-response-message+
		  (let ((message (read-socket-value 'string socket)))
		    (error 'postgresql-login-error
			   :connection connection :message message)))
		 (t
		  (error 'postgresql-login-error
			 :connection connection
			 :message
			 "Received garbled message from Postmaster"))))
	   ;; Start backend communication
	   (force-output socket)
	   (loop
	       (case (read-socket-value 'int8 socket)
		 (#.+backend-key-message+
		  (setf (postgresql-connection-pid connection)
			(read-socket-value 'int32 socket)
			(postgresql-connection-key connection)
			(read-socket-value 'int32 socket)))
		 (#.+ready-for-query-message+
		  (setq socket nil)
		  (return connection))
		 (#.+error-response-message+
		  (let ((message (read-socket-value 'string socket)))
		    (error 'postgresql-login-error
			   :connection connection
			   :message message)))
		 (#.+notice-response-message+
		  (let ((message (read-socket-value 'string socket)))
		    (warn 'postgresql-warning :connection connection
			  :message message)))
		 (t
		  (error 'postgresql-login-error
			 :connection connection
			 :message
			 "Received garbled message from Postmaster")))))
      (when socket
	(close socket)))))

(defun close-postgresql-connection (connection &optional abort)
  (unless abort
    (ignore-errors
      (send-terminate-message (postgresql-connection-socket connection))))
  (close (postgresql-connection-socket connection)))

(defun postgresql-connection-open-p (connection)
  (let ((socket (postgresql-connection-socket connection)))
    (and socket (streamp socket) (open-stream-p socket))))

(defun ensure-open-postgresql-connection (connection)
  (unless (postgresql-connection-open-p connection)
    (reopen-postgresql-connection connection)))

(defun process-async-messages (connection)
  (assert (postgresql-connection-open-p connection))
  ;; Process any asnychronous messages
  (loop with socket = (postgresql-connection-socket connection)
	while (listen socket)
	do
	(case (read-socket-value 'int8 socket)
	  (#.+notice-response-message+
	   (let ((message (read-socket-value 'string socket)))
	     (warn 'postgresql-warning :connection connection
		   :message message)))
	  (#.+notification-response-message+
	   (let ((pid (read-socket-value 'int32 socket))
		 (message (read-socket-value 'string socket)))
	     (when (= pid (postgresql-connection-pid connection))
	       (signal 'postgresql-notification :connection connection
		       :message message))))
	  (t
	   (close-postgresql-connection connection)
	   (error 'postgresql-fatal-error :connection connection
		  :message "Received garbled message from backend")))))

(defun start-query-execution (connection query)
  (ensure-open-postgresql-connection connection)
  (process-async-messages connection)
  (send-query-message (postgresql-connection-socket connection) query)
  (force-output (postgresql-connection-socket connection)))

(defun wait-for-query-results (connection)
  (assert (postgresql-connection-open-p connection))
  (let ((socket (postgresql-connection-socket connection))
	(cursor-name nil)
	(error nil))
    (loop
	(case (read-socket-value 'int8 socket)
	  (#.+completed-response-message+
	   (return (values :completed (read-socket-value 'string socket))))
	  (#.+cursor-response-message+
	   (setq cursor-name (read-socket-value 'string socket)))
	  (#.+row-description-message+
	   (let* ((count (read-socket-value 'int16 socket))
		  (fields
		   (loop repeat count
		     collect
		     (list
		      (read-socket-value 'string socket)
		      (read-socket-value 'int32 socket)
		      (read-socket-value 'int16 socket)
		      (read-socket-value 'int32 socket)))))
	     (return
	       (values :cursor
		       (make-postgresql-cursor :connection connection
					       :name cursor-name
					       :fields fields)))))
	  (#.+copy-in-response-message+
	   (return :copy-in))
	  (#.+copy-out-response-message+
	   (return :copy-out))
	  (#.+ready-for-query-message+
	   (when error
	     (error error))
	   (return nil))
	  (#.+error-response-message+
	   (let ((message (read-socket-value 'string socket)))
	     (setq error
		   (make-condition 'postgresql-error
				   :connection connection :message message))))
	  (#.+notice-response-message+
	   (let ((message (read-socket-value 'string socket)))
	     (warn 'postgresql-warning
		   :connection connection :message message)))
	  (#.+notification-response-message+
	   (let ((pid (read-socket-value 'int32 socket))
		 (message (read-socket-value 'string socket)))
	     (when (= pid (postgresql-connection-pid connection))
	       (signal 'postgresql-notification :connection connection
		       :message message))))
	  (t
	   (close-postgresql-connection connection)
	   (error 'postgresql-fatal-error :connection connection
		  :message "Received garbled message from backend"))))))

(defun read-null-bit-vector (socket count)
  (let ((result (make-array count :element-type 'bit)))
    (dotimes (offset (ceiling count 8))
      (loop with byte = (read-byte socket)
	    for index from (* offset 8) below (min count (* (1+ offset) 8))
	    for weight downfrom 7
	    do (setf (aref result index) (ldb (byte 1 weight) byte))))
    result))

(defun read-field (socket type)
  (let ((length (- (read-socket-value 'int32 socket) 4)))
    (case type
      ((:int :long :longlong)
       (read-integer-from-socket socket length))
      (:double
       (read-double-from-socket socket length))
      (t
       (let ((result (make-string length)))
	 (read-socket-sequence result socket)
	 result)))))

(uffi:def-constant +char-code-zero+ (char-code #\0))
(uffi:def-constant +char-code-minus+ (char-code #\-))
(uffi:def-constant +char-code-plus+ (char-code #\+))
(uffi:def-constant +char-code-period+ (char-code #\.))
(uffi:def-constant +char-code-lower-e+ (char-code #\e))
(uffi:def-constant +char-code-upper-e+ (char-code #\E))

(defun read-integer-from-socket (socket length)
  (declare (fixnum length))
  (if (zerop length)
      nil
    (let ((val 0)
	  (first-char (read-byte socket))
	  (minusp nil))
      (declare (fixnum first-char))
      (decf length) ;; read first char
      (cond
       ((= first-char +char-code-minus+)
	(setq minusp t))
       ((= first-char +char-code-plus+)
	)		;; nothing to do
       (t
	(setq val (- first-char +char-code-zero+))))

      (dotimes (i length)
	(declare (fixnum i))
	(setq val (+
		   (* 10 val)
		   (- (read-byte socket) +char-code-zero+))))
      (if minusp
	  (- val)
	val))))

(defmacro ascii-digit (int)
  (let ((offset (gensym)))
    `(let ((,offset (- ,int +char-code-zero+)))
      (declare (fixnum ,int ,offset))
      (if (and (>= ,offset 0)
	       (< ,offset 10))
	  ,offset
	  nil))))

(defun read-double-from-socket (socket length)
  (declare (fixnum length))
  (let ((before-decimal 0)
	(after-decimal 0)
	(decimal-count 0)
	(exponent 0)
	(decimalp nil)
	(minusp nil)
	(result nil)
	(char (read-byte socket)))
    (declare (fixnum char exponent decimal-count))
    (decf length) ;; already read first character
    (cond
      ((= char +char-code-minus+)
       (setq minusp t))
      ((= char +char-code-plus+)
       )
      ((= char +char-code-period+)
       (setq decimalp t))
      (t
       (setq before-decimal (ascii-digit char))
       (unless before-decimal
	 (error "Unexpected value"))))

    (dotimes (i length)
      (setq char (read-byte socket))
;;      (format t "~&len:~D, i:~D, char:~D, minusp:~A, decimalp:~A" length i char minusp decimalp)
      (let ((weight (ascii-digit char)))
	(cond
	  ((and weight (not decimalp)) ;; before decimal point
	   (setq before-decimal (+ weight (* 10 before-decimal))))
	  ((and weight decimalp) ;; after decimal point
	   (setq after-decimal (+ weight (* 10 after-decimal)))
	   (incf decimal-count))
	  ((and (= char +char-code-period+))
	   (setq decimalp t))
	  ((or (= char +char-code-lower-e+) 	      ;; E is for exponent
	       (= char +char-code-upper-e+))
	   (setq exponent (read-integer-from-socket socket (- length i 1)))
	   (setq exponent (or exponent 0))
	   (setq i length))
	  (t
	   (break "Unexpected value"))
	  )
	))
    (setq result (* (+ (coerce before-decimal 'double-float)
		       (* after-decimal
			  (expt 10 (- decimal-count))))
		    (expt 10 exponent)))
    (if minusp
	(- result)
	result)))

#+ignore
(defun read-double-from-socket (socket length)
  (let ((result (make-string length)))
    (read-socket-sequence result socket)
    (let ((*read-default-float-format* 'double-float))
      (read-from-string result))))

(defun read-cursor-row (cursor types)
  (let* ((connection (postgresql-cursor-connection cursor))
	 (socket (postgresql-connection-socket connection))
	 (fields (postgresql-cursor-fields cursor)))
    (assert (postgresql-connection-open-p connection))
    (loop
	(let ((code (read-socket-value 'int8 socket)))
	  (case code
	    (#.+ascii-row-message+
	     (return
	       (loop with count = (length fields)
		     with null-vector = (read-null-bit-vector socket count)
		     repeat count
		     for null-bit across null-vector
		     for i from 0
		     for null-p = (zerop null-bit)
		     if null-p
		     collect nil
		     else
		     collect
		     (read-field socket (nth i types)))))
	    (#.+binary-row-message+
	     (error "NYI"))
	    (#.+completed-response-message+
	     (return (values nil (read-socket-value 'string socket))))
	    (#.+error-response-message+
	     (let ((message (read-socket-value 'string socket)))
	       (error 'postgresql-error
		      :connection connection :message message)))
	    (#.+notice-response-message+
	     (let ((message (read-socket-value 'string socket)))
	       (warn 'postgresql-warning
		     :connection connection :message message)))
	    (#.+notification-response-message+
	     (let ((pid (read-socket-value 'int32 socket))
		   (message (read-socket-value 'string socket)))
	       (when (= pid (postgresql-connection-pid connection))
		 (signal 'postgresql-notification :connection connection
			 :message message))))
	    (t
	     (close-postgresql-connection connection)
	     (error 'postgresql-fatal-error :connection connection
		    :message "Received garbled message from backend")))))))

(defun map-into-indexed (result-seq func seq)
  (dotimes (i (length seq))
    (declare (fixnum i))
    (setf (elt result-seq i)
	  (funcall func (elt seq i) i)))
  result-seq)

(defun copy-cursor-row (cursor sequence types)
  (let* ((connection (postgresql-cursor-connection cursor))
	 (socket (postgresql-connection-socket connection))
	 (fields (postgresql-cursor-fields cursor)))
    (assert (= (length fields) (length sequence)))
    (loop
	(let ((code (read-socket-value 'int8 socket)))
	  (case code
	    (#.+ascii-row-message+
	     (return
	       #+ignore
	       (let* ((count (length sequence))
		      (null-vector (read-null-bit-vector socket count)))
		 (dotimes (i count)
		   (declare (fixnum i))
		   (if (zerop (elt null-vector i))
		       (setf (elt sequence i) nil)
		       (let ((value (read-field socket (nth i types))))
			 (setf (elt sequence i) value)))))
	       (map-into-indexed
		sequence
		#'(lambda (null-bit i)
		    (if (zerop null-bit)
			nil
			(read-field socket (nth i types))))
		(read-null-bit-vector socket (length sequence)))))
	    (#.+binary-row-message+
	     (error "NYI"))
	    (#.+completed-response-message+
	     (return (values nil (read-socket-value 'string socket))))
	    (#.+error-response-message+
	     (let ((message (read-socket-value 'string socket)))
	       (error 'postgresql-error
		      :connection connection :message message)))
	    (#.+notice-response-message+
	     (let ((message (read-socket-value 'string socket)))
	       (warn 'postgresql-warning
		     :connection connection :message message)))
	    (#.+notification-response-message+
	     (let ((pid (read-socket-value 'int32 socket))
		   (message (read-socket-value 'string socket)))
	       (when (= pid (postgresql-connection-pid connection))
		 (signal 'postgresql-notification :connection connection
			 :message message))))
	    (t
	     (close-postgresql-connection connection)
	     (error 'postgresql-fatal-error :connection connection
		    :message "Received garbled message from backend")))))))

(defun skip-cursor-row (cursor)
  (let* ((connection (postgresql-cursor-connection cursor))
	 (socket (postgresql-connection-socket connection))
	 (fields (postgresql-cursor-fields cursor)))
    (loop
	(let ((code (read-socket-value 'int8 socket)))
	  (case code
	    (#.+ascii-row-message+
	     (loop for null-bit across
		   (read-null-bit-vector socket (length fields))
		   do
		   (unless (zerop null-bit)
		     (let* ((length (read-socket-value 'int32 socket)))
		       (loop repeat (- length 4) do (read-byte socket)))))
	     (return t))
	    (#.+binary-row-message+
	     (error "NYI"))
	    (#.+completed-response-message+
	     (return (values nil (read-socket-value 'string socket))))
	    (#.+error-response-message+
	     (let ((message (read-socket-value 'string socket)))
	       (error 'postgresql-error
		      :connection connection :message message)))
	    (#.+notice-response-message+
	     (let ((message (read-socket-value 'string socket)))
	       (warn 'postgresql-warning
		     :connection connection :message message)))
	    (#.+notification-response-message+
	     (let ((pid (read-socket-value 'int32 socket))
		   (message (read-socket-value 'string socket)))
	       (when (= pid (postgresql-connection-pid connection))
		 (signal 'postgresql-notification :connection connection
			 :message message))))
	    (t
	     (close-postgresql-connection connection)
	     (error 'postgresql-fatal-error :connection connection
		    :message "Received garbled message from backend")))))))

(defun run-query (connection query &optional (types nil))
  (start-query-execution connection query)
  (multiple-value-bind (status cursor)
      (wait-for-query-results connection)
    (assert (eq status :cursor))
    (loop for row = (read-cursor-row cursor types)
	  while row
	  collect row
	  finally
	  (wait-for-query-results connection))))

;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          postgresql-socket.cl
;;;; Purpose:       Low-level PostgreSQL interface using sockets
;;;; Programmers:   Kevin M. Rosenberg based on
;;;;                Original code by Pierre R. Mai
;;;;
;;;; Date Started:  Feb 2002
;;;;
;;;; $Id: postgresql-socket-api.cl,v 1.9 2002/03/27 08:09:25 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.
;;;; *************************************************************************

;;;; Changes by Kevin Rosenberg
;;;;  - Added socket open functions for Allegro and Lispworks
;;;;  - Changed CMUCL FFI to UFFI
;;;;  - Added necessary (force-output) for socket streams on
;;;;     Allegro and Lispworks
;;;;  - Added initialization variable
;;;;  - Added field type processing

(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
(in-package :postgresql-socket)

(uffi:def-enum pgsql-ftype
    ((:bytea 17)
     (:int2 21)
     (:int4 23)
     (:int8 20)
     (:float4 700)
     (:float8 701)))

(defmethod database-type-library-loaded ((database-type
					  (eql :postgresql-socket)))
  "T if foreign library was able to be loaded successfully. Always true for
socket interface"
  t)

;;; Message I/O stuff

(defmacro define-message-constants (description &rest clauses)
  (assert (evenp (length clauses)))
  (loop with seen-characters = nil
	for (name char) on clauses by #'cddr
	for char-code = (char-code char)
	for doc-string = (format nil "~A (~:C): ~A" description char name)
	if (member char seen-characters)
	do (error "Duplicate message type ~@C for group ~A" char description)
	else
	collect
	`(defconstant ,name ,char-code ,doc-string)
	into result-clauses
	and do (push char seen-characters)
      finally
	(return `(progn ,@result-clauses))))

(eval-when (:compile-toplevel :load-toplevel :execute)
(define-message-constants "Backend Message Constants"
  +ascii-row-message+ #\D
  +authentication-message+ #\R
  +backend-key-message+ #\K
  +binary-row-message+ #\B
  +completed-response-message+ #\C
  +copy-in-response-message+ #\G
  +copy-out-response-message+ #\H
  +cursor-response-message+ #\P
  +empty-query-response-message+ #\I
  +error-response-message+ #\E
  +function-response-message+ #\V
  +notice-response-message+ #\N
  +notification-response-message+ #\A
  +ready-for-query-message+ #\Z
  +row-description-message+ #\T))

(defgeneric send-socket-value (type socket value))

(defmethod send-socket-value ((type (eql 'int32)) socket (value integer))
  (write-byte (ldb (byte 8 24) value) socket)
  (write-byte (ldb (byte 8 16) value) socket)
  (write-byte (ldb (byte 8 8) value) socket)
  (write-byte (ldb (byte 8 0) value) socket))

(defmethod send-socket-value ((type (eql 'int16)) socket (value integer))
  (write-byte (ldb (byte 8 8) value) socket)
  (write-byte (ldb (byte 8 0) value) socket))

(defmethod send-socket-value ((type (eql 'int8)) socket (value integer))
  (write-byte (ldb (byte 8 0) value) socket))

(defmethod send-socket-value ((type (eql 'string)) socket (value string))
  (loop for char across value
	for code = (char-code char)
	do (write-byte code socket)
	finally (write-byte 0 socket)))

(defmethod send-socket-value ((type (eql 'limstring)) socket (value string))
  (loop for char across value
	for code = (char-code char)
	do (write-byte code socket)))

(defmethod send-socket-value ((type (eql 'byte)) socket (value integer))
  (write-byte value socket))

(defmethod send-socket-value ((type (eql 'byte)) socket (value character))
  (write-byte (char-code value) socket))

(defmethod send-socket-value ((type (eql 'byte)) socket value)
  (write-sequence value socket))

(defgeneric read-socket-value (type socket))

(defmethod read-socket-value ((type (eql 'int32)) socket)
  (let ((result 0))
    (setf (ldb (byte 8 24) result) (read-byte socket))
    (setf (ldb (byte 8 16) result) (read-byte socket))
    (setf (ldb (byte 8 8) result) (read-byte socket))
    (setf (ldb (byte 8 0) result) (read-byte socket))
    result))

(defmethod read-socket-value ((type (eql 'int16)) socket)
  (let ((result 0))
    (setf (ldb (byte 8 8) result) (read-byte socket))
    (setf (ldb (byte 8 0) result) (read-byte socket))
    result))

(defmethod read-socket-value ((type (eql 'int8)) socket)
  (read-byte socket))

(defmethod read-socket-value ((type (eql 'string)) socket)
  (with-output-to-string (out)
    (loop for code = (read-byte socket)
	  until (zerop code)
	  do (write-char (code-char code) out))))

(defgeneric skip-socket-value (type socket))

(defmethod skip-socket-value ((type (eql 'int32)) socket)
  (dotimes (i 4) (read-byte socket)))

(defmethod skip-socket-value ((type (eql 'int16)) socket)
  (dotimes (i 2) (read-byte socket)))

(defmethod skip-socket-value ((type (eql 'int8)) socket)
  (read-byte socket))

(defmethod skip-socket-value ((type (eql 'string)) socket)
  (loop until (zerop (read-byte socket))))

(defmacro define-message-sender (name (&rest args) &rest clauses)
  (loop with socket-var = (gensym)
	for (type value) in clauses
	collect
	`(send-socket-value ',type ,socket-var ,value)
	into body
      finally
	(return
	  `(defun ,name (,socket-var ,@args)
	     ,@body))))

(defun pad-limstring (string limit)
  (let ((result (make-string limit :initial-element #\NULL)))
    (loop for char across string
	  for index from 0 below limit
	  do (setf (char result index) char))
    result))

(define-message-sender send-startup-message
    (database user &optional (command-line "") (backend-tty ""))
  (int32 296)                           ; Length
  (int32 #x00020000)                    ; Version 2.0
  (limstring (pad-limstring database 64))
  (limstring (pad-limstring user 32))
  (limstring (pad-limstring command-line 64))
  (limstring (pad-limstring "" 64))     ; Unused
  (limstring (pad-limstring backend-tty 64)))

(define-message-sender send-terminate-message ()
  (byte #\X))

(define-message-sender send-unencrypted-password-message (password)
  (int32 (+ 5 (length password)))
  (string password))

(define-message-sender send-query-message (query)
  (byte #\Q)
  (string query))

(define-message-sender send-encrypted-password-message (crypted-password)
  (int32 (+ 5 (length crypted-password)))
  (string crypted-password))

(define-message-sender send-cancel-request (pid key)
  (int32 16)                            ; Length
  (int32 80877102)                      ; Magic
  (int32 pid)
  (int32 key))

(defun read-socket-sequence (string stream)
"KMR -- Added to support reading from binary stream into a string"
  (declare (optimize (speed 3) (safety 0))
	   (string string))
  (dotimes (i (length string))
    (declare (fixnum i))
    (setf (char string i) (code-char (read-byte stream))))
  string)

;;; Support for encrypted password transmission

(defconstant +crypt-library+ "/usr/lib/libcrypt.so"
  "Name of the shared library to load in order to access the crypt
function named by `*crypt-function-name*'.")

(defvar *crypt-library-loaded* nil)

(defun crypt-password (password salt)
  "Encrypt a password for transmission to a PostgreSQL server."
  (unless *crypt-library-loaded*
    (uffi:load-foreign-library +crypt-library+ :supporting-libaries '("c"))
    (eval (uffi:def-function "crypt"
	      ((key :cstring)
	       (salt :cstring))
	    :returning :cstring))
    (setq *crypt-library-loaded* t))
   (uffi:with-cstring (password-cstring password)
     (uffi:with-cstring (salt-cstring salt)
       (uffi:convert-from-cstring (crypt password-cstring salt-cstring)))))
;;; Condition hierarchy

(define-condition postgresql-condition (condition)
  ((connection :initarg :connection :reader postgresql-condition-connection)
   (message :initarg :message :reader postgresql-condition-message))
  (:report
   (lambda (c stream)
     (format stream "~@<~A occurred on connection ~A. ~:@_Reason: ~A~:@>"
	     (type-of c)
	     (postgresql-condition-connection c)
	     (postgresql-condition-message c)))))

(define-condition postgresql-error (error postgresql-condition)
  ())

(define-condition postgresql-fatal-error (postgresql-error)
  ())

(define-condition postgresql-login-error (postgresql-fatal-error)
  ())

(define-condition postgresql-warning (warning postgresql-condition)
  ())

(define-condition postgresql-notification (postgresql-condition)
  ()
  (:report
   (lambda (c stream)
     (format stream "~@<Asynchronous notification on connection ~A: ~:@_~A~:@>"
	     (postgresql-condition-connection c)
	     (postgresql-condition-message c)))))

;;; Structures

(defstruct postgresql-connection
  host
  port
  database
  user
  password
  options
  tty
  socket
  pid
  key)

(defstruct postgresql-cursor
  connection
  name
  fields)

;;; Socket stuff

(defconstant +postgresql-server-default-port+ 5432
  "Default port of PostgreSQL server.")

(defvar *postgresql-server-socket-timeout* 60
  "Timeout in seconds for reads from the PostgreSQL server.")

#+cmu
(defun open-postgresql-socket (host port)
  (etypecase host
    (pathname
     ;; Directory to unix-domain socket
     (ext:connect-to-unix-socket
      (namestring
       (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
		      :defaults host))))
    (string
     (ext:connect-to-inet-socket host port))))

#+cmu
(defun open-postgresql-socket-stream (host port)
  (system:make-fd-stream
   (open-postgresql-socket host port)
   :input t :output t :element-type '(unsigned-byte 8)
   :buffering :none
   :timeout *postgresql-server-socket-timeout*))

#+allegro
(defun open-postgresql-socket-stream (host port)
  (etypecase host
    (pathname
     (let ((path (namestring
		  (make-pathname :name ".s.PGSQL" :type (princ-to-string port)
				 :defaults host))))
       (socket:make-socket :type :stream :address-family :file
			   :connect :active
			   :remote-filename path :local-filename path)))
    (string
     (socket:with-pending-connect
	 (mp:with-timeout (*postgresql-server-socket-timeout* (error "connect failed"))
	   (socket:make-socket :type :stream :address-family :internet
			       :remote-port port :remote-host host
			       :connect :active :nodelay t))))
    ))

#+lispworks
(defun open-postgresql-socket-stream (host port)
  (etypecase host
    (pathname
     (error "File sockets not supported on Lispworks."))
    (string
     (comm:open-tcp-stream host port :direction :io :element-type '(unsigned-byte 8)
			   :read-timeout *postgresql-server-socket-timeout*))
    ))

;;; Interface Functions

(defun open-postgresql-connection (&key (host (cmucl-compat:required-argument))
					(port +postgresql-server-default-port+)
					(database (cmucl-compat:required-argument))
					(user (cmucl-compat:required-argument))
					options tty password)
  "Open a connection to a PostgreSQL server with the given parameters.
Note that host, database and user arguments must be supplied.

If host is a pathname, it is assumed to name a directory containing
the local unix-domain sockets of the server, with port selecting which
of those sockets to open.  If host is a string, it is assumed to be
the name of the host running the PostgreSQL server.  In that case a
TCP connection to the given port on that host is opened in order to
communicate with the server.  In either case the port argument
defaults to `+postgresql-server-default-port+'.

Password is the clear-text password to be passed in the authentication
phase to the server.  Depending on the server set-up, it is either
passed in the clear, or encrypted via crypt and a server-supplied
salt.  In that case the alien function specified by `*crypt-library*'
and `*crypt-function-name*' is used for encryption.

Note that all the arguments (including the clear-text password
argument) are stored in the `postgresql-connection' structure, in
order to facilitate automatic reconnection in case of communication
troubles."
  (reopen-postgresql-connection
   (make-postgresql-connection :host host :port port
			       :options (or options "") :tty (or tty "")
			       :database database :user user
			       :password (or password ""))))

(defun reopen-postgresql-connection (connection)
  "Reopen the given PostgreSQL connection.  Closes any existing
connection, if it is still open."
  (when (postgresql-connection-open-p connection)
    (close-postgresql-connection connection))
  (let ((socket (open-postgresql-socket-stream
		  (postgresql-connection-host connection)
		  (postgresql-connection-port connection))))
    (unwind-protect
	 (progn
	   (setf (postgresql-connection-socket connection) socket)
	   (send-startup-message socket
				 (postgresql-connection-database connection)
				 (postgresql-connection-user connection)
				 (postgresql-connection-options connection)
				 (postgresql-connection-tty connection))
	   (force-output socket)
	   (loop
	       (case (read-socket-value 'int8 socket)
		 (#.+authentication-message+
		  (case (read-socket-value 'int32 socket)
		    (0 (return))
		    ((1 2)
		     (error 'postgresql-login-error
			    :connection connection
			    :message
			    "Postmaster expects unsupported Kerberos authentication."))
		    (3
		     (send-unencrypted-password-message
		      socket
		      (postgresql-connection-password connection)))
		    (4
		     (let ((salt (make-string 2)))
		       (read-socket-sequence salt socket)
		       (send-encrypted-password-message
			socket
			(crypt-password
			 (postgresql-connection-password connection) salt))))
		    (t
		     (error 'postgresql-login-error
			    :connection connection
			    :message
			    "Postmaster expects unknown authentication method."))))
		 (#.+error-response-message+
		  (let ((message (read-socket-value 'string socket)))
		    (error 'postgresql-login-error
			   :connection connection :message message)))
		 (t
		  (error 'postgresql-login-error
			 :connection connection
			 :message
			 "Received garbled message from Postmaster"))))
	   ;; Start backend communication
	   (force-output socket)
	   (loop
	       (case (read-socket-value 'int8 socket)
		 (#.+backend-key-message+
		  (setf (postgresql-connection-pid connection)
			(read-socket-value 'int32 socket)
			(postgresql-connection-key connection)
			(read-socket-value 'int32 socket)))
		 (#.+ready-for-query-message+
		  (setq socket nil)
		  (return connection))
		 (#.+error-response-message+
		  (let ((message (read-socket-value 'string socket)))
		    (error 'postgresql-login-error
			   :connection connection
			   :message message)))
		 (#.+notice-response-message+
		  (let ((message (read-socket-value 'string socket)))
		    (warn 'postgresql-warning :connection connection
			  :message message)))
		 (t
		  (error 'postgresql-login-error
			 :connection connection
			 :message
			 "Received garbled message from Postmaster")))))
      (when socket
	(close socket)))))

(defun close-postgresql-connection (connection &optional abort)
  (unless abort
    (ignore-errors
      (send-terminate-message (postgresql-connection-socket connection))))
  (close (postgresql-connection-socket connection)))

(defun postgresql-connection-open-p (connection)
  (let ((socket (postgresql-connection-socket connection)))
    (and socket (streamp socket) (open-stream-p socket))))

(defun ensure-open-postgresql-connection (connection)
  (unless (postgresql-connection-open-p connection)
    (reopen-postgresql-connection connection)))

(defun process-async-messages (connection)
  (assert (postgresql-connection-open-p connection))
  ;; Process any asnychronous messages
  (loop with socket = (postgresql-connection-socket connection)
	while (listen socket)
	do
	(case (read-socket-value 'int8 socket)
	  (#.+notice-response-message+
	   (let ((message (read-socket-value 'string socket)))
	     (warn 'postgresql-warning :connection connection
		   :message message)))
	  (#.+notification-response-message+
	   (let ((pid (read-socket-value 'int32 socket))
		 (message (read-socket-value 'string socket)))
	     (when (= pid (postgresql-connection-pid connection))
	       (signal 'postgresql-notification :connection connection
		       :message message))))
	  (t
	   (close-postgresql-connection connection)
	   (error 'postgresql-fatal-error :connection connection
		  :message "Received garbled message from backend")))))

(defun start-query-execution (connection query)
  (ensure-open-postgresql-connection connection)
  (process-async-messages connection)
  (send-query-message (postgresql-connection-socket connection) query)
  (force-output (postgresql-connection-socket connection)))

(defun wait-for-query-results (connection)
  (assert (postgresql-connection-open-p connection))
  (let ((socket (postgresql-connection-socket connection))
	(cursor-name nil)
	(error nil))
    (loop
	(case (read-socket-value 'int8 socket)
	  (#.+completed-response-message+
	   (return (values :completed (read-socket-value 'string socket))))
	  (#.+cursor-response-message+
	   (setq cursor-name (read-socket-value 'string socket)))
	  (#.+row-description-message+
	   (let* ((count (read-socket-value 'int16 socket))
		  (fields
		   (loop repeat count
		     collect
		     (list
		      (read-socket-value 'string socket)
		      (read-socket-value 'int32 socket)
		      (read-socket-value 'int16 socket)
		      (read-socket-value 'int32 socket)))))
	     (return
	       (values :cursor
		       (make-postgresql-cursor :connection connection
					       :name cursor-name
					       :fields fields)))))
	  (#.+copy-in-response-message+
	   (return :copy-in))
	  (#.+copy-out-response-message+
	   (return :copy-out))
	  (#.+ready-for-query-message+
	   (when error
	     (error error))
	   (return nil))
	  (#.+error-response-message+
	   (let ((message (read-socket-value 'string socket)))
	     (setq error
		   (make-condition 'postgresql-error
				   :connection connection :message message))))
	  (#.+notice-response-message+
	   (let ((message (read-socket-value 'string socket)))
	     (warn 'postgresql-warning
		   :connection connection :message message)))
	  (#.+notification-response-message+
	   (let ((pid (read-socket-value 'int32 socket))
		 (message (read-socket-value 'string socket)))
	     (when (= pid (postgresql-connection-pid connection))
	       (signal 'postgresql-notification :connection connection
		       :message message))))
	  (t
	   (close-postgresql-connection connection)
	   (error 'postgresql-fatal-error :connection connection
		  :message "Received garbled message from backend"))))))

(defun read-null-bit-vector (socket count)
  (let ((result (make-array count :element-type 'bit)))
    (dotimes (offset (ceiling count 8))
      (loop with byte = (read-byte socket)
	    for index from (* offset 8) below (min count (* (1+ offset) 8))
	    for weight downfrom 7
	    do (setf (aref result index) (ldb (byte 1 weight) byte))))
    result))

(defun read-field (socket type)
  (let ((length (- (read-socket-value 'int32 socket) 4)))
    (case type
      ((:int :long :longlong)
       (read-integer-from-socket socket length))
      (:double
       (read-double-from-socket socket length))
      (t
       (let ((result (make-string length)))
	 (read-socket-sequence result socket)
	 result)))))

(uffi:def-constant +char-code-zero+ (char-code #\0))
(uffi:def-constant +char-code-minus+ (char-code #\-))
(uffi:def-constant +char-code-plus+ (char-code #\+))
(uffi:def-constant +char-code-period+ (char-code #\.))
(uffi:def-constant +char-code-lower-e+ (char-code #\e))
(uffi:def-constant +char-code-upper-e+ (char-code #\E))

(defun read-integer-from-socket (socket length)
  (let ((val 0)
	(first-char (read-byte socket))
	(minusp nil))
    (declare (fixnum first-char))
    (if (zerop length)
	nil
	(progn
	  (cond
	    ((= first-char +char-code-minus+)
	     (setq minusp t))
	    ((= first-char +char-code-plus+)
	     ) ; nothing to do
	    (t
	     (setq val (- first-char +char-code-zero+))))
	  (dotimes (i (1- length))
	    (declare (fixnum i))
	    (setq val (+
		       (* 10 val)
		       (- (read-byte socket) +char-code-zero+))))
	  (if minusp
	      (- val)
	      val)))))

(defmacro ascii-digit (int)
  (let ((offset (gensym)))
    `(let ((,offset (- ,int +char-code-zero+)))
      (declare (fixnum ,int ,offset))
      (if (and (>= ,offset 0)
	       (< ,offset 10))
	  ,offset
	  nil))))

(defun read-double-from-socket (socket length)
  (let ((before-decimal 0)
	(after-decimal 0)
	(decimal-count 0)
	(exponent 0)
	(decimalp nil)
	(minusp nil)
	(result nil)
	(char (read-byte socket)))
    (declare (fixnum char))
    (decf length) ;; already read first character
    (cond
      ((= char +char-code-minus+)
       (setq minusp t)
       (setq char (read-byte socket))
       (decf length))
      ((= char +char-code-plus+)
       (setq char (read-byte socket))
       (decf length)))

    (dotimes (i length)
      (let ((weight (ascii-digit char)))
	(cond
	  ((and weight (not decimalp)) ;; before decimal point
	   (setq before-decimal (+ weight (* 10 before-decimal)))
	   (setq char (read-byte socket)))
	  ((and weight decimalp) ;; after decimal point
	   (setq after-decimal (+ weight (* 10 after-decimal)))
	   (incf decimal-count)
	   (setq char (read-byte socket)))
	  ((and (= char +char-code-period+))
	   (setq decimalp t)
	   (setq char (read-byte socket)))
	  ((or (= char +char-code-lower-e+) 	      ;; E is for exponent
	       (= char +char-code-upper-e+))
	   (setq exponent (read-integer-from-socket socket (- length i)))
	   (setq exponent (or exponent 0))
	   (setq i length))
	  (t
	   (break "Unexpected value"))
	  )
	))
    (setq result (* (+ (coerce before-decimal 'double-float)
		       (* after-decimal
			  (expt 10 (- decimal-count))))
		    (expt 10 exponent)))
    (if minusp
	(- result)
	result)))

#+ignore
(defun read-double-from-socket (socket length)
  (let ((result (make-string length)))
    (read-socket-sequence result socket)
    (let ((*read-default-float-format* 'double-float))
      (read-from-string result))))

(defun read-cursor-row (cursor types)
  (let* ((connection (postgresql-cursor-connection cursor))
	 (socket (postgresql-connection-socket connection))
	 (fields (postgresql-cursor-fields cursor)))
    (assert (postgresql-connection-open-p connection))
    (loop
	(let ((code (read-socket-value 'int8 socket)))
	  (case code
	    (#.+ascii-row-message+
	     (return
	       (loop with count = (length fields)
		     with null-vector = (read-null-bit-vector socket count)
		     repeat count
		     for null-bit across null-vector
		     for i from 0
		     for null-p = (zerop null-bit)
		     if null-p
		     collect nil
		     else
		     collect
		     (read-field socket (nth i types)))))
	    (#.+binary-row-message+
	     (error "NYI"))
	    (#.+completed-response-message+
	     (return (values nil (read-socket-value 'string socket))))
	    (#.+error-response-message+
	     (let ((message (read-socket-value 'string socket)))
	       (error 'postgresql-error
		      :connection connection :message message)))
	    (#.+notice-response-message+
	     (let ((message (read-socket-value 'string socket)))
	       (warn 'postgresql-warning
		     :connection connection :message message)))
	    (#.+notification-response-message+
	     (let ((pid (read-socket-value 'int32 socket))
		   (message (read-socket-value 'string socket)))
	       (when (= pid (postgresql-connection-pid connection))
		 (signal 'postgresql-notification :connection connection
			 :message message))))
	    (t
	     (close-postgresql-connection connection)
	     (error 'postgresql-fatal-error :connection connection
		    :message "Received garbled message from backend")))))))

(defun map-into-indexed (result-seq func seq)
  (dotimes (i (length seq))
    (declare (fixnum i))
    (setf (elt result-seq i)
	  (funcall func (elt seq i) i)))
  result-seq)

(defun copy-cursor-row (cursor sequence types)
  (let* ((connection (postgresql-cursor-connection cursor))
	 (socket (postgresql-connection-socket connection))
	 (fields (postgresql-cursor-fields cursor)))
    (assert (= (length fields) (length sequence)))
    (loop
	(let ((code (read-socket-value 'int8 socket)))
	  (case code
	    (#.+ascii-row-message+
	     (return
	       #+ignore
	       (let* ((count (length sequence))
		      (null-vector (read-null-bit-vector socket count)))
		 (dotimes (i count)
		   (declare (fixnum i))
		   (if (zerop (elt null-vector i))
		       (setf (elt sequence i) nil)
		       (let ((value (read-field socket (nth i types))))
			 (setf (elt sequence i) value)))))
	       (map-into-indexed
		sequence
		#'(lambda (null-bit i)
		    (if (zerop null-bit)
			nil
			(read-field socket (nth i types))))
		(read-null-bit-vector socket (length sequence)))))
	    (#.+binary-row-message+
	     (error "NYI"))
	    (#.+completed-response-message+
	     (return (values nil (read-socket-value 'string socket))))
	    (#.+error-response-message+
	     (let ((message (read-socket-value 'string socket)))
	       (error 'postgresql-error
		      :connection connection :message message)))
	    (#.+notice-response-message+
	     (let ((message (read-socket-value 'string socket)))
	       (warn 'postgresql-warning
		     :connection connection :message message)))
	    (#.+notification-response-message+
	     (let ((pid (read-socket-value 'int32 socket))
		   (message (read-socket-value 'string socket)))
	       (when (= pid (postgresql-connection-pid connection))
		 (signal 'postgresql-notification :connection connection
			 :message message))))
	    (t
	     (close-postgresql-connection connection)
	     (error 'postgresql-fatal-error :connection connection
		    :message "Received garbled message from backend")))))))

(defun skip-cursor-row (cursor)
  (let* ((connection (postgresql-cursor-connection cursor))
	 (socket (postgresql-connection-socket connection))
	 (fields (postgresql-cursor-fields cursor)))
    (loop
	(let ((code (read-socket-value 'int8 socket)))
	  (case code
	    (#.+ascii-row-message+
	     (loop for null-bit across
		   (read-null-bit-vector socket (length fields))
		   do
		   (unless (zerop null-bit)
		     (let* ((length (read-socket-value 'int32 socket)))
		       (loop repeat (- length 4) do (read-byte socket)))))
	     (return t))
	    (#.+binary-row-message+
	     (error "NYI"))
	    (#.+completed-response-message+
	     (return (values nil (read-socket-value 'string socket))))
	    (#.+error-response-message+
	     (let ((message (read-socket-value 'string socket)))
	       (error 'postgresql-error
		      :connection connection :message message)))
	    (#.+notice-response-message+
	     (let ((message (read-socket-value 'string socket)))
	       (warn 'postgresql-warning
		     :connection connection :message message)))
	    (#.+notification-response-message+
	     (let ((pid (read-socket-value 'int32 socket))
		   (message (read-socket-value 'string socket)))
	       (when (= pid (postgresql-connection-pid connection))
		 (signal 'postgresql-notification :connection connection
			 :message message))))
	    (t
	     (close-postgresql-connection connection)
	     (error 'postgresql-fatal-error :connection connection
		    :message "Received garbled message from backend")))))))

(defun run-query (connection query &optional (types nil))
  (start-query-execution connection query)
  (multiple-value-bind (status cursor)
      (wait-for-query-results connection)
    (assert (eq status :cursor))
    (loop for row = (read-cursor-row cursor types)
	  while row
	  collect row
	  finally
	  (wait-for-query-results connection))))