Fix single-pass sixtap filter on AMD hardware.

There's a weird bug that is preventing constant arrays from being
initialized properly. If you printf() the values before using them, they
are populated, but if you don't printf, then they are all 0's.

Work around this issue by adding an inline function to calculate a
short8 of filter values.

#pragma OPENCL EXTENSION cl_khr_byte_addressable_store : enable
#pragma OPENCL EXTENSION cl_amd_printf : enable

#define BILINEAR_ROW_SIZE 2
__constant int bilinear_filters[8*2] = {
    128, 0,
    112, 16,
    96, 32,
    80, 48,
    64, 64,
    48, 80,
    32, 96,
    16, 112
};

#define SIXTAP_ROW_SIZE 8
__constant short sub_pel_filters[64] = {
    //These were originally 8x6, but are padded for vector ops
     0, 0, 128, 0, 0, 0, 0, 0, /* note that 1/8 pel positions are just as per alpha -0.5 bicubic */
     0, -6, 123, 12, -1, 0, 0, 0,
     2, -11, 108, 36, -8, 1, 0, 0, /* New 1/4 pel 6 tap filter */
     0, -9, 93, 50, -6, 0, 0, 0,
     3, -16, 77, 77, -16, 3, 0, 0, /* New 1/2 pel 6 tap filter */
     0, -6, 50, 93, -9, 0, 0, 0,
     1, -8, 36, 108, -11, 2, 0, 0, /* New 1/4 pel 6 tap filter */
     0, -1, 12, 123, -6, 0, 0, 0,
};

__inline short8 sub_pel_filter_values(int offset){
    short8 result = 0;

    switch (offset){
        case 0:
            result.s2 = 128;
            break;
        case 1:
            result.s1 = -6;
            result.s2 = 123;
            result.s3 = 12;
            result.s4 = -1;
            break;
        case 2:
            result.s0 = 2;
            result.s1 = -11;
            result.s2 = 108;
            result.s3 = 36;
            result.s4 = -8;
            result.s5 = 1;
            break;
        case 3:
            result.s1 = -9;
            result.s2 = 93;
            result.s3 = 50;
            result.s4 = -6;
            break;
        case 4:
             result.s0 = 3;
             result.s1 = -16;
             result.s2 = 77;
             result.s3 = 77;
             result.s4 = -16;
             result.s5 = 3;
             break;
        case 5:
            result.s1 = -6;
            result.s2 = 50;
            result.s3 = 93;
            result.s4 = -9;
            break;
        case 6:
            result.s0 = 1;
            result.s1 = -8;
            result.s2 = 36;
            result.s3 = 108;
            result.s4 = -11;
            result.s5 = 2;
            break;
        case 7:
            result.s1 = -1;
            result.s2 = 12;
            result.s3 = 123;
            result.s4 = -6;
            break;
        default:
            break;
    }

    return result;
}

kernel void vp8_filter_block2d_first_pass_kernel(
    __global unsigned char *src_base,
    int src_offset,
    __global int *output_ptr,
    unsigned int src_pixels_per_line,
    unsigned int output_height,
    unsigned int output_width,
    int filter_offset
){
    uint tid = get_global_id(0);

    global unsigned char *src_ptr = &src_base[src_offset];
    //Note that src_offset will be reset later, which is why we use it now

    int Temp;

    __constant short *vp8_filter = &sub_pel_filters[filter_offset*SIXTAP_ROW_SIZE];

    if (tid < (output_width*output_height)){
        src_offset = tid + (tid/output_width * (src_pixels_per_line - output_width));

        Temp = (int)(src_ptr[src_offset - 2] * vp8_filter[0]) +
           (int)(src_ptr[src_offset - 1] * vp8_filter[1]) +
           (int)(src_ptr[src_offset]     * vp8_filter[2]) +
           (int)(src_ptr[src_offset + 1] * vp8_filter[3]) +
           (int)(src_ptr[src_offset + 2] * vp8_filter[4]) +
           (int)(src_ptr[src_offset + 3] * vp8_filter[5]) +
           (VP8_FILTER_WEIGHT >> 1);      /* Rounding */

        /* Normalize back to 0-255 */
        Temp = Temp >> VP8_FILTER_SHIFT;

        if (Temp < 0)
            Temp = 0;
        else if ( Temp > 255 )
            Temp = 255;

        output_ptr[tid] = Temp;
    }

}

kernel void vp8_filter_block2d_second_pass_kernel
(
    __global int *src_base,
    int src_offset,
    __global unsigned char *output_base,
    int output_offset,
    int output_pitch,
    unsigned int src_pixels_per_line,
    unsigned int pixel_step,
    unsigned int output_height,
    unsigned int output_width,
    int filter_offset
) {

    uint i = get_global_id(0);

    global int *src_ptr = &src_base[src_offset];
    global unsigned char *output_ptr = &output_base[output_offset];

    int out_offset; //Not same as output_offset...
    int Temp;
    int PS2 = 2*(int)pixel_step;
    int PS3 = 3*(int)pixel_step;

    unsigned int src_increment = src_pixels_per_line - output_width;

    __constant short *vp8_filter = &sub_pel_filters[filter_offset*SIXTAP_ROW_SIZE];

    if (i < (output_width * output_height)){
        out_offset = i/output_width;
        src_offset = out_offset;

        src_offset = i + (src_offset * src_increment);
        out_offset = i%output_width + (out_offset * output_pitch);

        /* Apply filter */
        Temp = ((int)src_ptr[src_offset - PS2] * vp8_filter[0]) +
           ((int)src_ptr[src_offset -(int)pixel_step] * vp8_filter[1]) +
           ((int)src_ptr[src_offset]                  * vp8_filter[2]) +
           ((int)src_ptr[src_offset + pixel_step]     * vp8_filter[3]) +
           ((int)src_ptr[src_offset + PS2]       * vp8_filter[4]) +
           ((int)src_ptr[src_offset + PS3]       * vp8_filter[5]) +
           (VP8_FILTER_WEIGHT >> 1);   /* Rounding */

        /* Normalize back to 0-255 */
        Temp = Temp >> VP8_FILTER_SHIFT;
        if (Temp < 0)
            Temp = 0;
        else if (Temp > 255)
            Temp = 255;

        output_ptr[out_offset] = (unsigned char)Temp;
    }
}

kernel void vp8_filter_block2d_bil_first_pass_kernel(
    __global unsigned char *src_base,
    int src_offset,
    __global int *output_ptr,
    unsigned int src_pixels_per_line,
    unsigned int output_height,
    unsigned int output_width,
    int filter_offset
)
{
    uint tid = get_global_id(0);

    if (tid < output_width * output_height){
        global unsigned char *src_ptr = &src_base[src_offset];

        unsigned int i, j;
        __constant int *vp8_filter = &bilinear_filters[filter_offset*BILINEAR_ROW_SIZE];

        unsigned int out_row,out_offset;
        int src_increment = src_pixels_per_line - output_width;

        i = tid / output_width;
        j = tid % output_width;

        src_offset = i*(output_width+src_increment) + j;
        out_row = output_width * i;

        out_offset = out_row + j;

        /* Apply bilinear filter */
        output_ptr[out_offset] = (((int)src_ptr[src_offset]   * vp8_filter[0]) +
                 ((int)src_ptr[src_offset+1] * vp8_filter[1]) +
                 (VP8_FILTER_WEIGHT / 2)) >> VP8_FILTER_SHIFT;
    }
}

kernel void vp8_filter_block2d_bil_second_pass_kernel
(
    __global int *src_ptr,
    __global unsigned char *output_base,
    int output_offset,
    int output_pitch,
    unsigned int output_height,
    unsigned int output_width,
    int filter_offset
)
{

    uint tid = get_global_id(0);

    if (tid < output_width * output_height){
        global unsigned char *output_ptr = &output_base[output_offset];

        unsigned int i, j;
        int Temp;
        __constant int *vp8_filter = &bilinear_filters[filter_offset*BILINEAR_ROW_SIZE];

        int out_offset;
        int src_offset;

        i = tid / output_width;
        j = tid % output_width;

        src_offset = i*(output_width) + j;
        out_offset = i*output_pitch + j;

        /* Apply filter */
        Temp = ((int)src_ptr[src_offset]         * vp8_filter[0]) +
               ((int)src_ptr[src_offset+output_width] * vp8_filter[1]) +
               (VP8_FILTER_WEIGHT / 2);

        output_ptr[out_offset++] = (unsigned int)(Temp >> VP8_FILTER_SHIFT);
    }
}

//Called from reconinter_cl.c
kernel void vp8_memcpy_kernel(
    global unsigned char *src_base,
    int src_offset,
    int src_stride,
    global unsigned char *dst_base,
    int dst_offset,
    int dst_stride,
    int num_bytes,
    int num_iter
){

    int i,r;
    global unsigned char *src = &src_base[src_offset];
    global unsigned char *dst = &dst_base[dst_offset];
    src_offset = dst_offset = 0;

    r = get_global_id(1);
    if (r < get_global_size(1)){
        i = get_global_id(0);
        if (i < get_global_size(0)){
            src_offset = r*src_stride + i;
            dst_offset = r*dst_stride + i;
            dst[dst_offset] = src[src_offset];
        }
    }
}

//Not used currently.
void vp8_memset_short(
    global short *mem,
    int offset,
    short newval,
    unsigned int size
)
{
    int tid = get_global_id(0);

    if (tid < (size/2)){
        mem[offset+tid/2] = newval;
    }
}

__kernel void vp8_bilinear_predict4x4_kernel
(
        __global unsigned char *src_base,
        int src_offset,
        int src_pixels_per_line,
        int xoffset,
        int yoffset,
        __global unsigned char *dst_base,
        int dst_offset,
        int dst_pitch,
        __global int *int_mem
)
{
    int Height = 4, Width = 4;

    /* First filter 1-D horizontally... */
    vp8_filter_block2d_bil_first_pass_kernel(src_base, src_offset, int_mem, src_pixels_per_line, Height + 1, Width, xoffset);

    /* then 1-D vertically... */
    vp8_filter_block2d_bil_second_pass_kernel(int_mem, dst_base, dst_offset, dst_pitch, Height, Width, yoffset);
}

__kernel void vp8_bilinear_predict8x8_kernel
(
    __global unsigned char *src_base,
    int src_offset,
    int src_pixels_per_line,
    int xoffset,
    int yoffset,
    __global unsigned char *dst_base,
    int dst_offset,
    int dst_pitch,
    __global int *int_mem
)
{
    int Height = 8, Width = 8;

    /* First filter 1-D horizontally... */
    vp8_filter_block2d_bil_first_pass_kernel(src_base, src_offset, int_mem, src_pixels_per_line, Height + 1, Width, xoffset);

    /* then 1-D vertically... */
    vp8_filter_block2d_bil_second_pass_kernel(int_mem, dst_base, dst_offset, dst_pitch, Height, Width, yoffset);

}

__kernel void vp8_bilinear_predict8x4_kernel
(
    __global unsigned char *src_base,
    int src_offset,
    int src_pixels_per_line,
    int xoffset,
    int yoffset,
    __global unsigned char *dst_base,
    int dst_offset,
    int dst_pitch,
    __global int *int_mem
)
{
    int Height = 4, Width = 8;

    /* First filter 1-D horizontally... */
    vp8_filter_block2d_bil_first_pass_kernel(src_base, src_offset, int_mem, src_pixels_per_line, Height + 1, Width, xoffset);

    /* then 1-D vertically... */
    vp8_filter_block2d_bil_second_pass_kernel(int_mem, dst_base, dst_offset, dst_pitch, Height, Width, yoffset);
}

__kernel void vp8_bilinear_predict16x16_kernel
(
    __global unsigned char *src_base,
    int src_offset,
    int src_pixels_per_line,
    int xoffset,
    int yoffset,
    __global unsigned char *dst_base,
    int dst_offset,
    int dst_pitch,
    __global int *int_mem
)
{

    int Height = 16, Width = 16;

    /* First filter 1-D horizontally... */
    vp8_filter_block2d_bil_first_pass_kernel(src_base, src_offset, int_mem, src_pixels_per_line, Height + 1, Width, xoffset);

    /* then 1-D vertically... */
    vp8_filter_block2d_bil_second_pass_kernel(int_mem, dst_base, dst_offset, dst_pitch, Height, Width, yoffset);

}

void vp8_filter_block2d_first_pass(
    global unsigned char *src_base,
    int src_offset,
    local int *output_ptr,
    unsigned int src_pixels_per_line,
    unsigned int pixel_step,
    unsigned int output_height,
    unsigned int output_width,
    int filter_offset
){
    uint tid = get_global_id(0);
    uint i = tid;

    int nthreads = get_global_size(0);
    int ngroups = get_num_groups(0);
    int lsize = get_local_size(0);

    //printf("global_size = %d, ngroups = %d, lsize = %d\n", nthreads, ngroups, lsize);

    global unsigned char *src_ptr = &src_base[src_offset];
    //Note that src_offset will be reset later, which is why we capture it now

    int Temp;

    //__constant short *vp8_filter = &sub_pel_filters[filter_offset*SIXTAP_ROW_SIZE];
    //printf("offset = %d\n", filter_offset*SIXTAP_ROW_SIZE);
    if (tid < (output_width*output_height)){
        short8 filter = sub_pel_filter_values(filter_offset);

        //printf("filter_offset = %d, filters = {%d, %d, %d, %d, %d, %d}\n", filter_offset, filter0, filter1, filter2, filter3, filter4, filter5);
        //printf("sub_pel_filters[0][2] = %d\n", sub_pel_filters[2]);

        if (ngroups > 1){
            //This is generally only true on Apple CPU-CL, which gives a group
            //size of 1, regardless of the CPU core count.
            for (int iter=0; iter < ngroups; iter++){
                i = iter * lsize + get_local_id(0);
                src_offset = i + (i/output_width * (src_pixels_per_line - output_width));

                //printf("src_offset = %d\n", src_offset);

                Temp = (int)(src_ptr[src_offset - 2] * filter.s0) +
                       (int)(src_ptr[src_offset - 1] * filter.s1) +
                       (int)(src_ptr[src_offset]     * filter.s2) +
                       (int)(src_ptr[src_offset + 1] * filter.s3) +
                       (int)(src_ptr[src_offset + 2] * filter.s4) +
                       (int)(src_ptr[src_offset + 3] * filter.s5) +
                       (VP8_FILTER_WEIGHT >> 1);      /* Rounding */

                /* Normalize back to 0-255 */
                Temp >>= VP8_FILTER_SHIFT;

                if (Temp < 0)
                    Temp = 0;
                else if ( Temp > 255 )
                    Temp = 255;

                output_ptr[i] = Temp;
                //if (get_group_id(0) == 0 && iter ==1 && get_local_id(0)==1){
                    //printf("short size = %d, filter_offset = %d, sub_pel_filters - vp8_filter = %d\n", sizeof(short), filter_offset, sub_pel_filters[0] - vp8_filter);
                //    printf("Input values = {%d, %d, %d, %d, %d, %d}, filters = {%d, %d, %d, %d, %d, %d}\n",
                //            src_ptr[src_offset-2], src_ptr[src_offset-1], src_ptr[src_offset],
                //            src_ptr[src_offset+1], src_ptr[src_offset+2], src_ptr[src_offset+3],
                //            filter.s0, filter.s1, filter.s2, filter.s3, filter.s4, filter.s5);
                    //printf("Wrote %d to index %d\n", Temp, i);
                //}
            }
        } else {
            src_offset = i + (i/output_width * (src_pixels_per_line - output_width));

            Temp = (int)(src_ptr[src_offset - 2] * filter.s0) +
                   (int)(src_ptr[src_offset - 1] * filter.s1) +
                   (int)(src_ptr[src_offset]     * filter.s2) +
                   (int)(src_ptr[src_offset + 1] * filter.s3) +
                   (int)(src_ptr[src_offset + 2] * filter.s4) +
                   (int)(src_ptr[src_offset + 3] * filter.s5) +
                   (VP8_FILTER_WEIGHT >> 1);      /* Rounding */

            /* Normalize back to 0-255 */
            Temp >>= VP8_FILTER_SHIFT;

            if (Temp < 0)
                Temp = 0;
            else if ( Temp > 255 )
                Temp = 255;

            output_ptr[i] = Temp;
            //if (i == 5 && )
        }
    }

    //Add a fence so that no 2nd pass stuff starts before 1st pass writes are done.
    barrier(CLK_LOCAL_MEM_FENCE);
    write_mem_fence(CLK_LOCAL_MEM_FENCE);
}

void vp8_filter_block2d_second_pass
(
    local int *src_ptr,
    global unsigned char *output_base,
    int output_offset,
    int output_pitch,
    unsigned int src_pixels_per_line,
    unsigned int pixel_step,
    unsigned int output_height,
    unsigned int output_width,
    int filter_offset
) {

    global unsigned char *output_ptr = &output_base[output_offset];

    int out_offset; //Not same as output_offset...
    int src_offset;
    int Temp;
    int PS2 = 2*(int)pixel_step;
    int PS3 = 3*(int)pixel_step;

    unsigned int src_increment = src_pixels_per_line - output_width;

    uint i = get_global_id(0);

    short8 vp8_filter = sub_pel_filter_values(filter_offset);

    if (i < (output_width * output_height)){
        out_offset = i/output_width;
        src_offset = out_offset;

        src_offset = i + (src_offset * src_increment);
        out_offset = i%output_width + (out_offset * output_pitch);

        /* Apply filter */
        Temp = ((int)src_ptr[src_offset - PS2] * vp8_filter.s0) +
           ((int)src_ptr[src_offset -(int)pixel_step] * vp8_filter.s1) +
           ((int)src_ptr[src_offset]                  * vp8_filter.s2) +
           ((int)src_ptr[src_offset + pixel_step]     * vp8_filter.s3) +
           ((int)src_ptr[src_offset + PS2]            * vp8_filter.s4) +
           ((int)src_ptr[src_offset + PS3]       * vp8_filter.s5) +
           (VP8_FILTER_WEIGHT >> 1);   /* Rounding */

        /* Normalize back to 0-255 */
        Temp = Temp >> VP8_FILTER_SHIFT;
        if (Temp < 0)
            Temp = 0;
        else if (Temp > 255)
            Temp = 255;

        output_ptr[out_offset] = (unsigned char)Temp;
    }
}

__kernel void vp8_sixtap_predict_kernel
(
    __global unsigned char  *src_ptr,
    int src_offset,
    int  src_pixels_per_line,
    int  xoffset,
    int  yoffset,
    __global unsigned char *dst_ptr,
    int dst_offset,
    int  dst_pitch
)
{

    local int FData[9*4];

    /* First filter 1-D horizontally... */
    vp8_filter_block2d_first_pass(src_ptr, src_offset, FData, src_pixels_per_line, 1, 9, 4, xoffset);

    /* then filter vertically... */
    vp8_filter_block2d_second_pass(&FData[8], dst_ptr, dst_offset, dst_pitch, 4, 4, 4, 4, yoffset);
}

__kernel void vp8_sixtap_predict8x8_kernel
(
    __global unsigned char  *src_ptr,
    int src_offset,
    int  src_pixels_per_line,
    int  xoffset,
    int  yoffset,
    __global unsigned char *dst_ptr,
    int dst_offset,
    int  dst_pitch
)
{
    local int FData[13*16];   /* Temp data bufffer used in filtering */

    /* First filter 1-D horizontally... */
    vp8_filter_block2d_first_pass(src_ptr, src_offset, FData, src_pixels_per_line, 1, 13, 8, xoffset);

    /* then filter vertically... */
    vp8_filter_block2d_second_pass(&FData[16], dst_ptr, dst_offset, dst_pitch, 8, 8, 8, 8, yoffset);

}

__kernel void vp8_sixtap_predict8x4_kernel
(
    __global unsigned char  *src_ptr,
    int src_offset,
    int  src_pixels_per_line,
    int  xoffset,
    int  yoffset,
    __global unsigned char *dst_ptr,
    int dst_offset,
    int  dst_pitch
)
{
    local int FData[13*16];   /* Temp data buffer used in filtering */

    /* First filter 1-D horizontally... */
    vp8_filter_block2d_first_pass(src_ptr, src_offset, FData, src_pixels_per_line, 1, 9, 8, xoffset);

    /* then filter verticaly... */
    vp8_filter_block2d_second_pass(&FData[16], dst_ptr, dst_offset, dst_pitch, 8, 8, 4, 8, yoffset);
}

__kernel void vp8_sixtap_predict16x16_kernel
(
    __global unsigned char  *src_ptr,
    int src_offset,
    int  src_pixels_per_line,
    int  xoffset,
    int  yoffset,
    __global unsigned char *dst_ptr,
    int dst_offset,
    int  dst_pitch
)
{
    local int FData[21*24];   /* Temp data buffer used in filtering */

    /* First filter 1-D horizontally... */
    vp8_filter_block2d_first_pass(src_ptr, src_offset, FData, src_pixels_per_line, 1, 21, 16, xoffset);

    /* then filter verticaly... */
    vp8_filter_block2d_second_pass(&FData[32], dst_ptr, dst_offset, dst_pitch, 16, 16, 16, 16, yoffset);

    return;
}

#pragma OPENCL EXTENSION cl_khr_byte_addressable_store : enable
#pragma OPENCL EXTENSION cl_amd_printf : enable

__constant int bilinear_filters[8][2] = {
    { 128, 0},
    { 112, 16},
    { 96, 32},
    { 80, 48},
    { 64, 64},
    { 48, 80},
    { 32, 96},
    { 16, 112}
};

__constant short sub_pel_filters[8][8] = {
    //These were originally 8x6, but are padded for vector ops
    { 0, 0, 128, 0, 0, 0, 0, 0}, /* note that 1/8 pel positions are just as per alpha -0.5 bicubic */
    { 0, -6, 123, 12, -1, 0, 0, 0},
    { 2, -11, 108, 36, -8, 1, 0, 0}, /* New 1/4 pel 6 tap filter */
    { 0, -9, 93, 50, -6, 0, 0, 0},
    { 3, -16, 77, 77, -16, 3, 0, 0}, /* New 1/2 pel 6 tap filter */
    { 0, -6, 50, 93, -9, 0, 0, 0},
    { 1, -8, 36, 108, -11, 2, 0, 0}, /* New 1/4 pel 6 tap filter */
    { 0, -1, 12, 123, -6, 0, 0, 0},
};

kernel void vp8_filter_block2d_first_pass_kernel(
    __global unsigned char *src_base,
    int src_offset,
    __global int *output_ptr,
    unsigned int src_pixels_per_line,
    unsigned int output_height,
    unsigned int output_width,
    int filter_offset
){
    uint tid = get_global_id(0);

    global unsigned char *src_ptr = &src_base[src_offset];
    //Note that src_offset will be reset later, which is why we use it now

    int Temp;

    __constant short *vp8_filter = sub_pel_filters[filter_offset];

    if (tid < (output_width*output_height)){
        src_offset = tid + (tid/output_width * (src_pixels_per_line - output_width));

        Temp = (int)(src_ptr[src_offset - 2] * vp8_filter[0]) +
           (int)(src_ptr[src_offset - 1] * vp8_filter[1]) +
           (int)(src_ptr[src_offset]     * vp8_filter[2]) +
           (int)(src_ptr[src_offset + 1] * vp8_filter[3]) +
           (int)(src_ptr[src_offset + 2] * vp8_filter[4]) +
           (int)(src_ptr[src_offset + 3] * vp8_filter[5]) +
           (VP8_FILTER_WEIGHT >> 1);      /* Rounding */

        /* Normalize back to 0-255 */
        Temp = Temp >> VP8_FILTER_SHIFT;

        if (Temp < 0)
            Temp = 0;
        else if ( Temp > 255 )
            Temp = 255;

        output_ptr[tid] = Temp;
    }

}

kernel void vp8_filter_block2d_second_pass_kernel
(
    __global int *src_base,
    int src_offset,
    __global unsigned char *output_base,
    int output_offset,
    int output_pitch,
    unsigned int src_pixels_per_line,
    unsigned int pixel_step,
    unsigned int output_height,
    unsigned int output_width,
    int filter_offset
) {

    uint i = get_global_id(0);

    global int *src_ptr = &src_base[src_offset];
    global unsigned char *output_ptr = &output_base[output_offset];

    int out_offset; //Not same as output_offset...
    int Temp;
    int PS2 = 2*(int)pixel_step;
    int PS3 = 3*(int)pixel_step;

    unsigned int src_increment = src_pixels_per_line - output_width;

    __constant short *vp8_filter = sub_pel_filters[filter_offset];

    if (i < (output_width * output_height)){
        out_offset = i/output_width;
        src_offset = out_offset;

        src_offset = i + (src_offset * src_increment);
        out_offset = i%output_width + (out_offset * output_pitch);

        /* Apply filter */
        Temp = ((int)src_ptr[src_offset - PS2] * vp8_filter[0]) +
           ((int)src_ptr[src_offset -(int)pixel_step] * vp8_filter[1]) +
           ((int)src_ptr[src_offset]                  * vp8_filter[2]) +
           ((int)src_ptr[src_offset + pixel_step]     * vp8_filter[3]) +
           ((int)src_ptr[src_offset + PS2]       * vp8_filter[4]) +
           ((int)src_ptr[src_offset + PS3]       * vp8_filter[5]) +
           (VP8_FILTER_WEIGHT >> 1);   /* Rounding */

        /* Normalize back to 0-255 */
        Temp = Temp >> VP8_FILTER_SHIFT;
        if (Temp < 0)
            Temp = 0;
        else if (Temp > 255)
            Temp = 255;

        output_ptr[out_offset] = (unsigned char)Temp;
    }
}

kernel void vp8_filter_block2d_bil_first_pass_kernel(
    __global unsigned char *src_base,
    int src_offset,
    __global int *output_ptr,
    unsigned int src_pixels_per_line,
    unsigned int output_height,
    unsigned int output_width,
    int filter_offset
)
{
    uint tid = get_global_id(0);

    if (tid < output_width * output_height){
        global unsigned char *src_ptr = &src_base[src_offset];

        unsigned int i, j;
        __constant int *vp8_filter = bilinear_filters[filter_offset];

        unsigned int out_row,out_offset;
        int src_increment = src_pixels_per_line - output_width;

        i = tid / output_width;
        j = tid % output_width;

        src_offset = i*(output_width+src_increment) + j;
        out_row = output_width * i;

        out_offset = out_row + j;

        /* Apply bilinear filter */
        output_ptr[out_offset] = (((int)src_ptr[src_offset]   * vp8_filter[0]) +
                 ((int)src_ptr[src_offset+1] * vp8_filter[1]) +
                 (VP8_FILTER_WEIGHT / 2)) >> VP8_FILTER_SHIFT;
    }
}

kernel void vp8_filter_block2d_bil_second_pass_kernel
(
    __global int *src_ptr,
    __global unsigned char *output_base,
    int output_offset,
    int output_pitch,
    unsigned int output_height,
    unsigned int output_width,
    int filter_offset
)
{

    uint tid = get_global_id(0);

    if (tid < output_width * output_height){
        global unsigned char *output_ptr = &output_base[output_offset];

        unsigned int i, j;
        int Temp;
        __constant int *vp8_filter = bilinear_filters[filter_offset];

        int out_offset;
        int src_offset;

        i = tid / output_width;
        j = tid % output_width;

        src_offset = i*(output_width) + j;
        out_offset = i*output_pitch + j;

        /* Apply filter */
        Temp = ((int)src_ptr[src_offset]         * vp8_filter[0]) +
               ((int)src_ptr[src_offset+output_width] * vp8_filter[1]) +
               (VP8_FILTER_WEIGHT / 2);

        output_ptr[out_offset++] = (unsigned int)(Temp >> VP8_FILTER_SHIFT);
    }
}

//Called from reconinter_cl.c
kernel void vp8_memcpy_kernel(
    global unsigned char *src_base,
    int src_offset,
    int src_stride,
    global unsigned char *dst_base,
    int dst_offset,
    int dst_stride,
    int num_bytes,
    int num_iter
){

    int i,r;
    global unsigned char *src = &src_base[src_offset];
    global unsigned char *dst = &dst_base[dst_offset];
    src_offset = dst_offset = 0;

    r = get_global_id(1);
    if (r < get_global_size(1)){
        i = get_global_id(0);
        if (i < get_global_size(0)){
            src_offset = r*src_stride + i;
            dst_offset = r*dst_stride + i;
            dst[dst_offset] = src[src_offset];
        }
    }
}

//Not used currently.
void vp8_memset_short(
    global short *mem,
    int offset,
    short newval,
    unsigned int size
)
{
    int tid = get_global_id(0);

    if (tid < (size/2)){
        mem[offset+tid/2] = newval;
    }
}

__kernel void vp8_bilinear_predict4x4_kernel
(
        __global unsigned char *src_base,
        int src_offset,
        int src_pixels_per_line,
        int xoffset,
        int yoffset,
        __global unsigned char *dst_base,
        int dst_offset,
        int dst_pitch,
        __global int *int_mem
)
{
    int Height = 4, Width = 4;

    /* First filter 1-D horizontally... */
    vp8_filter_block2d_bil_first_pass_kernel(src_base, src_offset, int_mem, src_pixels_per_line, Height + 1, Width, xoffset);

    /* then 1-D vertically... */
    vp8_filter_block2d_bil_second_pass_kernel(int_mem, dst_base, dst_offset, dst_pitch, Height, Width, yoffset);
}

__kernel void vp8_bilinear_predict8x8_kernel
(
    __global unsigned char *src_base,
    int src_offset,
    int src_pixels_per_line,
    int xoffset,
    int yoffset,
    __global unsigned char *dst_base,
    int dst_offset,
    int dst_pitch,
    __global int *int_mem
)
{
    int Height = 8, Width = 8;

    /* First filter 1-D horizontally... */
    vp8_filter_block2d_bil_first_pass_kernel(src_base, src_offset, int_mem, src_pixels_per_line, Height + 1, Width, xoffset);

    /* then 1-D vertically... */
    vp8_filter_block2d_bil_second_pass_kernel(int_mem, dst_base, dst_offset, dst_pitch, Height, Width, yoffset);

}

__kernel void vp8_bilinear_predict8x4_kernel
(
    __global unsigned char *src_base,
    int src_offset,
    int src_pixels_per_line,
    int xoffset,
    int yoffset,
    __global unsigned char *dst_base,
    int dst_offset,
    int dst_pitch,
    __global int *int_mem
)
{
    int Height = 4, Width = 8;

    /* First filter 1-D horizontally... */
    vp8_filter_block2d_bil_first_pass_kernel(src_base, src_offset, int_mem, src_pixels_per_line, Height + 1, Width, xoffset);

    /* then 1-D vertically... */
    vp8_filter_block2d_bil_second_pass_kernel(int_mem, dst_base, dst_offset, dst_pitch, Height, Width, yoffset);
}

__kernel void vp8_bilinear_predict16x16_kernel
(
    __global unsigned char *src_base,
    int src_offset,
    int src_pixels_per_line,
    int xoffset,
    int yoffset,
    __global unsigned char *dst_base,
    int dst_offset,
    int dst_pitch,
    __global int *int_mem
)
{

    int Height = 16, Width = 16;

    /* First filter 1-D horizontally... */
    vp8_filter_block2d_bil_first_pass_kernel(src_base, src_offset, int_mem, src_pixels_per_line, Height + 1, Width, xoffset);

    /* then 1-D vertically... */
    vp8_filter_block2d_bil_second_pass_kernel(int_mem, dst_base, dst_offset, dst_pitch, Height, Width, yoffset);

}

void vp8_filter_block2d_first_pass(
    global unsigned char *src_base,
    int src_offset,
    local int *output_ptr,
    unsigned int src_pixels_per_line,
    unsigned int pixel_step,
    unsigned int output_height,
    unsigned int output_width,
    int filter_offset
){
    uint tid = get_global_id(0);
    uint i = tid;

    int nthreads = get_global_size(0);
    int ngroups = nthreads / get_local_size(0);

    global unsigned char *src_ptr = &src_base[src_offset];
    //Note that src_offset will be reset later, which is why we capture it now

    int Temp;

    __constant short *vp8_filter = sub_pel_filters[filter_offset];

    if (tid < (output_width*output_height)){
        short filter0 = vp8_filter[0];
        short filter1 = vp8_filter[1];
        short filter2 = vp8_filter[2];
        short filter3 = vp8_filter[3];
        short filter4 = vp8_filter[4];
        short filter5 = vp8_filter[5];

        if (ngroups > 1){
            //This is generally only true on Apple CPU-CL, which gives a group
            //size of 1, regardless of the CPU core count.
            for (i=0; i < output_width*output_height; i++){
                src_offset = i + (i/output_width * (src_pixels_per_line - output_width));

                Temp = (int)(src_ptr[src_offset - 2] * filter0) +
                       (int)(src_ptr[src_offset - 1] * filter1) +
                       (int)(src_ptr[src_offset]     * filter2) +
                       (int)(src_ptr[src_offset + 1] * filter3) +
                       (int)(src_ptr[src_offset + 2] * filter4) +
                       (int)(src_ptr[src_offset + 3] * filter5) +
                       (VP8_FILTER_WEIGHT >> 1);      /* Rounding */

                /* Normalize back to 0-255 */
                Temp >>= VP8_FILTER_SHIFT;

                if (Temp < 0)
                    Temp = 0;
                else if ( Temp > 255 )
                    Temp = 255;

                output_ptr[i] = Temp;
            }
        } else {
            src_offset = i + (i/output_width * (src_pixels_per_line - output_width));

            Temp = (int)(src_ptr[src_offset - 2] * filter0) +
                   (int)(src_ptr[src_offset - 1] * filter1) +
                   (int)(src_ptr[src_offset]     * filter2) +
                   (int)(src_ptr[src_offset + 1] * filter3) +
                   (int)(src_ptr[src_offset + 2] * filter4) +
                   (int)(src_ptr[src_offset + 3] * filter5) +
                   (VP8_FILTER_WEIGHT >> 1);      /* Rounding */

            /* Normalize back to 0-255 */
            Temp >>= VP8_FILTER_SHIFT;

            if (Temp < 0)
                Temp = 0;
            else if ( Temp > 255 )
                Temp = 255;

            output_ptr[i] = Temp;
        }
    }

    //Add a fence so that no 2nd pass stuff starts before 1st pass writes are done.
    barrier(CLK_LOCAL_MEM_FENCE);
}

void vp8_filter_block2d_second_pass
(
    local int *src_ptr,
    global unsigned char *output_base,
    int output_offset,
    int output_pitch,
    unsigned int src_pixels_per_line,
    unsigned int pixel_step,
    unsigned int output_height,
    unsigned int output_width,
    int filter_offset
) {

    global unsigned char *output_ptr = &output_base[output_offset];

    int out_offset; //Not same as output_offset...
    int src_offset;
    int Temp;
    int PS2 = 2*(int)pixel_step;
    int PS3 = 3*(int)pixel_step;

    unsigned int src_increment = src_pixels_per_line - output_width;

    uint i = get_global_id(0);

    __constant short *vp8_filter = sub_pel_filters[filter_offset];

    if (i < (output_width * output_height)){
        out_offset = i/output_width;
        src_offset = out_offset;

        src_offset = i + (src_offset * src_increment);
        out_offset = i%output_width + (out_offset * output_pitch);

        /* Apply filter */
        Temp = ((int)src_ptr[src_offset - PS2] * vp8_filter[0]) +
           ((int)src_ptr[src_offset -(int)pixel_step] * vp8_filter[1]) +
           ((int)src_ptr[src_offset]                  * vp8_filter[2]) +
           ((int)src_ptr[src_offset + pixel_step]     * vp8_filter[3]) +
           ((int)src_ptr[src_offset + PS2]            * vp8_filter[4]) +
           ((int)src_ptr[src_offset + PS3]       * vp8_filter[5]) +
           (VP8_FILTER_WEIGHT >> 1);   /* Rounding */

        /* Normalize back to 0-255 */
        Temp = Temp >> VP8_FILTER_SHIFT;
        if (Temp < 0)
            Temp = 0;
        else if (Temp > 255)
            Temp = 255;

        output_ptr[out_offset] = (unsigned char)Temp;
    }
}

__kernel void vp8_sixtap_predict_kernel
(
    __global unsigned char  *src_ptr,
    int src_offset,
    int  src_pixels_per_line,
    int  xoffset,
    int  yoffset,
    __global unsigned char *dst_ptr,
    int dst_offset,
    int  dst_pitch
)
{

    local int FData[9*4];

    /* First filter 1-D horizontally... */
    vp8_filter_block2d_first_pass(src_ptr, src_offset, FData, src_pixels_per_line, 1, 9, 4, xoffset);

    /* then filter vertically... */
    vp8_filter_block2d_second_pass(&FData[8], dst_ptr, dst_offset, dst_pitch, 4, 4, 4, 4, yoffset);
}

__kernel void vp8_sixtap_predict8x8_kernel
(
    __global unsigned char  *src_ptr,
    int src_offset,
    int  src_pixels_per_line,
    int  xoffset,
    int  yoffset,
    __global unsigned char *dst_ptr,
    int dst_offset,
    int  dst_pitch
)
{
    local int FData[13*16];   /* Temp data bufffer used in filtering */

    /* First filter 1-D horizontally... */
    vp8_filter_block2d_first_pass(src_ptr, src_offset, FData, src_pixels_per_line, 1, 13, 8, xoffset);

    /* then filter vertically... */
    vp8_filter_block2d_second_pass(&FData[16], dst_ptr, dst_offset, dst_pitch, 8, 8, 8, 8, yoffset);

}

__kernel void vp8_sixtap_predict8x4_kernel
(
    __global unsigned char  *src_ptr,
    int src_offset,
    int  src_pixels_per_line,
    int  xoffset,
    int  yoffset,
    __global unsigned char *dst_ptr,
    int dst_offset,
    int  dst_pitch
)
{
    local int FData[13*16];   /* Temp data buffer used in filtering */

    /* First filter 1-D horizontally... */
    vp8_filter_block2d_first_pass(src_ptr, src_offset, FData, src_pixels_per_line, 1, 9, 8, xoffset);

    /* then filter verticaly... */
    vp8_filter_block2d_second_pass(&FData[16], dst_ptr, dst_offset, dst_pitch, 8, 8, 4, 8, yoffset);
}

__kernel void vp8_sixtap_predict16x16_kernel
(
    __global unsigned char  *src_ptr,
    int src_offset,
    int  src_pixels_per_line,
    int  xoffset,
    int  yoffset,
    __global unsigned char *dst_ptr,
    int dst_offset,
    int  dst_pitch
)
{
    local int FData[21*24];   /* Temp data buffer used in filtering */

    /* First filter 1-D horizontally... */
    vp8_filter_block2d_first_pass(src_ptr, src_offset, FData, src_pixels_per_line, 1, 21, 16, xoffset);

    /* then filter verticaly... */
    vp8_filter_block2d_second_pass(&FData[32], dst_ptr, dst_offset, dst_pitch, 16, 16, 16, 16, yoffset);

    return;
}


r1784: refined reader macro

r1784: refined reader macro

;; tester.cl
;; A test harness for Allegro CL.
;;
;; copyright (c) 1985-1986 Franz Inc, Alameda, CA
;; copyright (c) 1986-2001 Franz Inc, Berkeley, CA - All rights reserved.
;;
;; This code is free software; you can redistribute it and/or
;; modify it under the terms of the version 2.1 of
;; the GNU Lesser General Public License as published by
;; the Free Software Foundation, as clarified by the Franz
;; preamble to the LGPL found in
;; http://opensource.franz.com/preamble.html.
;;
;; This code is distributed in the hope that it will be useful,
;; but without any warranty; without even the implied warranty of
;; merchantability or fitness for a particular purpose.  See the GNU
;; Lesser General Public License for more details.
;;
;; Version 2.1 of the GNU Lesser General Public License can be
;; found at http://opensource.franz.com/license.html.
;; If it is not present, you can access it from
;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
;; version) or write to the Free Software Foundation, Inc., 59 Temple
;; Place, Suite 330, Boston, MA  02111-1307  USA
;;
;;;; from the original ACL 6.1 sources:
;; $Id: acl-compat-tester.cl,v 1.3 2002/04/20 22:55:02 kevin Exp $

(defpackage :util.test
  (:use :common-lisp)
  (:shadow #:test)
  (:export
;;;; Control variables:
   #:*break-on-test-failures*
   #:*error-protect-tests*
   #:*test-errors*
   #:*test-successes*
   #:*test-unexpected-failures*

;;;; The test macros:
   #:test
   #:test-error
   #:test-no-error
   #:test-warning
   #:test-no-warning

   #:with-tests
   ))

(in-package :util.test)

#+cmu
(unless (find-class 'break nil)
  (define-condition break (simple-condition) ()))

(define-condition simple-break (error simple-condition) ())

;; the if* macro used in Allegro:
;;
;; This is in the public domain... please feel free to put this definition
;; in your code or distribute it with your version of lisp.

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defvar if*-keyword-list '("then" "thenret" "else" "elseif")))

(defmacro if* (&rest args)
   (do ((xx (reverse args) (cdr xx))
	(state :init)
	(elseseen nil)
	(totalcol nil)
	(lookat nil nil)
	(col nil))
       ((null xx)
	(cond ((eq state :compl)
	       `(cond ,@totalcol))
	      (t (error "if*: illegal form ~s" args))))
       (cond ((and (symbolp (car xx))
		   (member (symbol-name (car xx))
			   if*-keyword-list
			   :test #'string-equal))
	      (setq lookat (symbol-name (car xx)))))

       (cond ((eq state :init)
	      (cond (lookat (cond ((string-equal lookat "thenret")
				   (setq col nil
					 state :then))
				  (t (error
				      "if*: bad keyword ~a" lookat))))
		    (t (setq state :col
			     col nil)
		       (push (car xx) col))))
	     ((eq state :col)
	      (cond (lookat
		     (cond ((string-equal lookat "else")
			    (cond (elseseen
				   (error
				    "if*: multiples elses")))
			    (setq elseseen t)
			    (setq state :init)
			    (push `(t ,@col) totalcol))
			   ((string-equal lookat "then")
			    (setq state :then))
			   (t (error "if*: bad keyword ~s"
					      lookat))))
		    (t (push (car xx) col))))
	     ((eq state :then)
	      (cond (lookat
		     (error
		      "if*: keyword ~s at the wrong place " (car xx)))
		    (t (setq state :compl)
		       (push `(,(car xx) ,@col) totalcol))))
	     ((eq state :compl)
	      (cond ((not (string-equal lookat "elseif"))
		     (error "if*: missing elseif clause ")))
	      (setq state :init)))))

(defvar *break-on-test-failures* nil
  "When a test failure occurs, common-lisp:break is called, allowing
interactive debugging of the failure.")

(defvar *test-errors* 0
  "The value is the number of test errors which have occurred.")
(defvar *test-successes* 0
  "The value is the number of test successes which have occurred.")
(defvar *test-unexpected-failures* 0
  "The value is the number of unexpected test failures which have occurred.")

(defvar *error-protect-tests* nil
  "Protect each test from errors.  If an error occurs, then that will be
taken as a test failure unless test-error is being used.")

(defmacro test-values-errorset (form &optional announce catch-breaks)
  ;; internal macro
  (let ((g-announce (gensym))
	(g-catch-breaks (gensym)))
    `(let* ((,g-announce ,announce)
	    (,g-catch-breaks ,catch-breaks))
       (handler-case (cons t (multiple-value-list ,form))
	 (condition (condition)
	   (if* (and (null ,g-catch-breaks)
		     (typep condition 'simple-break))
	      then (break condition)
	    elseif ,g-announce
	      then (format *error-output* "~&Condition type: ~a~%"
			   (class-of condition))
		   (format *error-output* "~&Message: ~a~%" condition))
	   condition)))))

(defmacro test-values (form &optional announce catch-breaks)
  ;; internal macro
  (if* *error-protect-tests*
     then `(test-values-errorset ,form ,announce ,catch-breaks)
     else `(cons t (multiple-value-list ,form))))

(defmacro test (expected-value test-form
		&key (test #'eql test-given)
		     (multiple-values nil multiple-values-given)
		     (fail-info nil fail-info-given)
		     (known-failure nil known-failure-given)

;;;;;;;;;; internal, undocumented keywords:
;;;; Note about these keywords: if they were documented, we'd have a
;;;; problem, since they break the left-to-right order of evaluation.
;;;; Specifically, errorset breaks it, and I don't see any way around
;;;; that.  `errorset' is used by the old test.cl module (eg,
;;;; test-equal-errorset).
		     errorset
		     reported-form
		     (wanted-message nil wanted-message-given)
		     (got-message nil got-message-given))
  "Perform a single test.  `expected-value' is the reference value for the
test.  `test-form' is a form that will produce the value to be compared to
the expected-value.  If the values are not the same, then an error is
logged, otherwise a success is logged.

Normally the comparison of values is done with `eql'.  The `test' keyword
argument can be used to specify other comparison functions, such as eq,
equal,equalp, string=, string-equal, etc.

Normally, only the first return value from the test-form is considered,
however if `multiple-values' is t, then all values returned from test-form
are considered.

`fail-info' allows more information to be printed with a test failure.

`known-failure' marks the test as a known failure.  This allows for
programs that do regression analysis on the output from a test run to
discriminate on new versus known failures."
  `(test-check
    :expected-result ,expected-value
    :test-results
    (,(if errorset 'test-values-errorset 'test-values) ,test-form t)
    ,@(when test-given `(:predicate ,test))
    ,@(when multiple-values-given `(:multiple-values ,multiple-values))
    ,@(when fail-info-given `(:fail-info ,fail-info))
    ,@(when known-failure-given `(:known-failure ,known-failure))
    :test-form ',(if reported-form reported-form test-form)
    ,@(when wanted-message-given `(:wanted-message ,wanted-message))
    ,@(when got-message-given `(:got-message ,got-message))))

(defmethod conditionp ((thing condition)) t)
(defmethod conditionp ((thing t)) nil)

(defmacro test-error (form &key announce
				catch-breaks
				(fail-info nil fail-info-given)
				(known-failure nil known-failure-given)
				(condition-type ''simple-error)
				(include-subtypes nil include-subtypes-given)
				(format-control nil format-control-given)
				(format-arguments nil format-arguments-given))
  "Test that `form' signals an error. The order of evaluation of the
arguments is keywords first, then test form.

If `announce' is non-nil, then cause the error message to be printed.

The `catch-breaks' is non-nil then consider a call to common-lisp:break an
`error'.

`fail-info' allows more information to be printed with a test failure.

`known-failure' marks the test as a known failure.  This allows for
programs that do regression analysis on the output from a test run to
discriminate on new versus known failures.

If `condition-type' is non-nil, it should be a symbol naming a condition
type, which is used to check against the signalled condition type.  The
test will fail if they do not match.

`include-subtypes', used with `condition-type', can be used to match a
condition to an entire subclass of the condition type hierarchy.

`format-control' and `format-arguments' can be used to check the error
message itself."
  (let ((g-announce (gensym))
	(g-catch-breaks (gensym))
	(g-fail-info (gensym))
	(g-known-failure (gensym))
	(g-condition-type (gensym))
	(g-include-subtypes (gensym))
	(g-format-control (gensym))
	(g-format-arguments (gensym))
	(g-c (gensym)))
    `(let* ((,g-announce ,announce)
	    (,g-catch-breaks ,catch-breaks)
	    ,@(when fail-info-given `((,g-fail-info ,fail-info)))
	    ,@(when known-failure-given `((,g-known-failure ,known-failure)))
	    (,g-condition-type ,condition-type)
	    ,@(when include-subtypes-given
		`((,g-include-subtypes ,include-subtypes)))
	    ,@(when format-control-given
		`((,g-format-control ,format-control)))
	    ,@(when format-arguments-given
		`((,g-format-arguments ,format-arguments)))
	    (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
       (test-check
	:predicate #'eq
	:expected-result t
	:test-results
	(test-values (and (conditionp ,g-c)
			  ,@(if* include-subtypes-given
			       then `((if* ,g-include-subtypes
					 then (typep ,g-c ,g-condition-type)
					 else (eq (class-of ,g-c)
						  (find-class
						   ,g-condition-type))))
			       else `((eq (class-of ,g-c)
					  (find-class ,g-condition-type))))
			  ,@(when format-control-given
			      `((or
				 (null ,g-format-control)
				 (string=
				  (concatenate 'simple-string
				    "~1@<" ,g-format-control "~:@>")
				  (simple-condition-format-control ,g-c)))))
			  ,@(when format-arguments-given
			      `((or
				 (null ,g-format-arguments)
				 (equal
				  ,g-format-arguments
				  (simple-condition-format-arguments ,g-c))))))
		     t)
	:test-form ',form
	,@(when fail-info-given `(:fail-info ,g-fail-info))
	,@(when known-failure-given `(:known-failure ,g-known-failure))
	:condition-type ,g-condition-type
	:condition ,g-c
	,@(when include-subtypes-given
	    `(:include-subtypes ,g-include-subtypes))
	,@(when format-control-given
	    `(:format-control ,g-format-control))
	,@(when format-arguments-given
	    `(:format-arguments ,g-format-arguments))))))

(defmacro test-no-error (form &key announce
				   catch-breaks
				   (fail-info nil fail-info-given)
				   (known-failure nil known-failure-given))
  "Test that `form' does not signal an error.  The order of evaluation of
the arguments is keywords first, then test form.

If `announce' is non-nil, then cause the error message to be printed.

The `catch-breaks' is non-nil then consider a call to common-lisp:break an
`error'.

`fail-info' allows more information to be printed with a test failure.

`known-failure' marks the test as a known failure.  This allows for
programs that do regression analysis on the output from a test run to
discriminate on new versus known failures."
  (let ((g-announce (gensym))
	(g-catch-breaks (gensym))
	(g-fail-info (gensym))
	(g-known-failure (gensym))
	(g-c (gensym)))
    `(let* ((,g-announce ,announce)
	    (,g-catch-breaks ,catch-breaks)
	    ,@(when fail-info-given `((,g-fail-info ,fail-info)))
	    ,@(when known-failure-given `((,g-known-failure ,known-failure)))
	    (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
       (test-check
	:predicate #'eq
	:expected-result t
	:test-results (test-values (not (conditionp ,g-c)))
	:test-form ',form
	:condition ,g-c
	,@(when fail-info-given `(:fail-info ,g-fail-info))
	,@(when known-failure-given `(:known-failure ,g-known-failure))))))

(defvar *warn-cookie* (cons nil nil))

(defmacro test-warning (form &key fail-info known-failure)
  "Test that `form' signals a warning.  The order of evaluation of
the arguments is keywords first, then test form.

`fail-info' allows more information to be printed with a test failure.

`known-failure' marks the test as a known failure.  This allows for
programs that do regression analysis on the output from a test run to
discriminate on new versus known failures."
  (let ((g-fail-info (gensym))
	(g-known-failure (gensym))
	(g-value (gensym)))
    `(let* ((,g-fail-info ,fail-info)
	    (,g-known-failure ,known-failure)
	    (,g-value (test-values-errorset ,form nil t)))
       (test
	*warn-cookie*
	(if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
	   then *warn-cookie*
	   else ;; test produced no warning
		nil)
	:test #'eq
	:reported-form ,form ;; quoted by test macro
	:wanted-message "a warning"
	:got-message "no warning"
	:fail-info ,g-fail-info
	:known-failure ,g-known-failure))))

(defmacro test-no-warning (form &key fail-info known-failure)
  "Test that `form' does not signal a warning.  The order of evaluation of
the arguments is keywords first, then test form.

`fail-info' allows more information to be printed with a test failure.

`known-failure' marks the test as a known failure.  This allows for
programs that do regression analysis on the output from a test run to
discriminate on new versus known failures."
  (let ((g-fail-info (gensym))
	(g-known-failure (gensym))
	(g-value (gensym)))
    `(let* ((,g-fail-info ,fail-info)
	    (,g-known-failure ,known-failure)
	    (,g-value (test-values-errorset ,form nil t)))
       (test
	*warn-cookie*
	(if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
	   then nil ;; test produced warning
	   else *warn-cookie*)
	:test #'eq
	:reported-form ',form
	:wanted-message "no warning"
	:got-message "a warning"
	:fail-info ,g-fail-info
	:known-failure ,g-known-failure))))

(defvar *announce-test* nil) ;; if true announce each test that was done

(defmacro errorset (form &optional announce catch-breaks)
  ;; Evaluate FORM, and if there are no errors and FORM returns
  ;; values v1,v2,...,vn, then return values t,v1,v2,...,vn.  If an
  ;; error occurs while evaluating FORM, then return nil immediately.
  ;; If ANNOUNCE is t, then the error message will be printed out.
  (if catch-breaks
      `(handler-case (values-list (cons t (multiple-value-list ,form)))
         (error (condition)
           (declare (ignore-if-unused condition))
           ,@(if announce `((format *error-output* "~&Error: ~a~%" condition)))
           nil)
         (simple-break (condition)
           (declare (ignore-if-unused condition))
           ,@(if announce `((format *error-output* "~&Warning: ~a~%" condition))
)
           nil))
    `(handler-case (values-list (cons t (multiple-value-list ,form)))
       (error (condition)
         (declare (ignore-if-unused condition))
         ,@(if announce `((format *error-output* "~&Error: ~a~%" condition)))
         nil))))

(defun test-check (&key (predicate #'eql)
			expected-result test-results test-form
			multiple-values fail-info known-failure
			wanted-message got-message condition-type condition
			include-subtypes format-control format-arguments
		   &aux fail predicate-failed got wanted)
  ;; for debugging large/complex test sets:
  (when *announce-test*
    (format t "Just did test ~s~%" test-form)
    (force-output))

  ;; this is an internal function
  (flet ((check (expected-result result)
	   (let* ((results
		   (multiple-value-list
		    (errorset (funcall predicate expected-result result) t)))
		  (failed (null (car results))))
	     (if* failed
		then (setq predicate-failed t)
		     nil
		else (cadr results)))))
    (when (conditionp test-results)
      (setq condition test-results)
      (setq test-results nil))
    (when (null (car test-results))
      (setq fail t))
    (if* (and (not fail) (not multiple-values))
       then ;; should be a single result
	    ;; expected-result is the single result wanted
	    (when (not (and (cdr test-results)
			    (check expected-result (cadr test-results))))
	      (setq fail t))
	    (when (and (not fail) (cddr test-results))
	      (setq fail 'single-got-multiple))
       else ;; multiple results wanted
	    ;; expected-result is a list of results, each of which
	    ;; should be checked against the corresponding test-results
	    ;; using the predicate
	    (do ((got (cdr test-results) (cdr got))
		 (want expected-result (cdr want)))
		((or (null got) (null want))
		 (when (not (and (null want) (null got)))
		   (setq fail t)))
	      (when (not (check (car got) (car want)))
		(return (setq fail t)))))
    (if* fail
       then (when (not known-failure)
	      (format *error-output*
		      "~& * * * UNEXPECTED TEST FAILURE * * *~%")
	      (incf *test-unexpected-failures*))
	    (format *error-output* "~&Test failed: ~@[known failure: ~*~]~s~%"
		    known-failure test-form)
	    (if* (eq 'single-got-multiple fail)
	       then (format
		     *error-output*
		     "~
Reason: additional value were returned from test form.~%")
	     elseif predicate-failed
	       then (format *error-output* "Reason: predicate error.~%")
	     elseif (null (car test-results))
	       then (format *error-output* "~
Reason: an error~@[ (of type `~s')~] was detected.~%"
			    (when condition (class-of condition)))
	     elseif condition
	       then (if* (not (conditionp condition))
		       then (format *error-output* "~
Reason: expected but did not detect an error of type `~s'.~%"
				    condition-type)
		     elseif (null condition-type)
		       then (format *error-output* "~
Reason: detected an unexpected error of type `~s':
        ~a.~%"
				    (class-of condition)
				    condition)
		     elseif (not (if* include-subtypes
				    then (typep condition condition-type)
				    else (eq (class-of condition)
					     (find-class condition-type))))
		       then (format *error-output* "~
Reason: detected an incorrect condition type.~%")
			    (format *error-output*
				    "  wanted: ~s~%" condition-type)
			    (format *error-output*
				    "     got: ~s~%" (class-of condition))
		     elseif (and format-control
				 (not (string=
				       (setq got
					 (concatenate 'simple-string
					   "~1@<" format-control "~:@>"))
				       (setq wanted
					 (simple-condition-format-control
					  condition)))))
		       then ;; format control doesn't match
			    (format *error-output* "~
Reason: the format-control was incorrect.~%")
			    (format *error-output* "  wanted: ~s~%" wanted)
			    (format *error-output* "     got: ~s~%" got)
		     elseif (and format-arguments
				 (not (equal
				       (setq got format-arguments)
				       (setq wanted
					 (simple-condition-format-arguments
					  condition)))))
		       then (format *error-output* "~
Reason: the format-arguments were incorrect.~%")
			    (format *error-output* "  wanted: ~s~%" wanted)
			    (format *error-output* "     got: ~s~%" got)
		       else ;; what else????
			    (error "internal-error"))
	       else (let ((*print-length* 50)
			  (*print-level* 10))
		      (if* wanted-message
			 then (format *error-output*
				      "  wanted: ~a~%" wanted-message)
			 else (if* (not multiple-values)
				 then (format *error-output*
					      "  wanted: ~s~%"
					      expected-result)
				 else (format
				       *error-output*
				       "  wanted values: ~{~s~^, ~}~%"
				       expected-result)))
		      (if* got-message
			 then (format *error-output*
				      "     got: ~a~%" got-message)
			 else (if* (not multiple-values)
				 then (format *error-output* "     got: ~s~%"
				       (second test-results))
				 else (format
				       *error-output*
				       "     got values: ~{~s~^, ~}~%"
				       (cdr test-results))))))
	    (when fail-info
	      (format *error-output* "Additional info: ~a~%" fail-info))
	    (incf *test-errors*)
	    (when *break-on-test-failures*
	      (break "~a is non-nil." '*break-on-test-failures*))
       else (when known-failure
	      (format *error-output*
		      "~&Expected test failure for ~s did not occur.~%"
		      test-form)
	      (when fail-info
		(format *error-output* "Additional info: ~a~%" fail-info))
	      (setq fail t))
	    (incf *test-successes*))
    (not fail)))

(defmacro with-tests ((&key (name "unnamed")) &body body)
  (let ((g-name (gensym)))
    `(flet ((doit () ,@body))
       (let ((,g-name ,name)
	     (*test-errors* 0)
	     (*test-successes* 0)
	     (*test-unexpected-failures* 0))
	 (format *error-output* "Begin ~a test~%" ,g-name)
	 (if* *break-on-test-failures*
	    then (doit)
	    else (handler-case (doit)
		   (error (c)
		     (format
		      *error-output*
		      "~
~&Test ~a aborted by signalling an uncaught error:~%~a~%"
		      ,g-name c))))
	 #+allegro
	 (let ((state (sys:gsgc-switch :print)))
	   (setf (sys:gsgc-switch :print) nil)
	   (format t "~&**********************************~%" ,g-name)
	   (format t "End ~a test~%" ,g-name)
	   (format t "Errors detected in this test: ~s " *test-errors*)
	   (unless (zerop *test-unexpected-failures*)
	     (format t "UNEXPECTED: ~s" *test-unexpected-failures*))
	   (format t "~%Successes this test:~s~%" *test-successes*)
	   (setf (sys:gsgc-switch :print) state))
	 #-allegro
	 (progn
	   (format t "~&**********************************~%" ,g-name)
	   (format t "End ~a test~%" ,g-name)
	   (format t "Errors detected in this test: ~s " *test-errors*)
	   (unless (zerop *test-unexpected-failures*)
	     (format t "UNEXPECTED: ~s" *test-unexpected-failures*))
	   (format t "~%Successes this test:~s~%" *test-successes*))
	 ))))

(provide :tester #+module-versions 1.1)

;; tester.cl
;; A test harness for Allegro CL.
;;
;; copyright (c) 1985-1986 Franz Inc, Alameda, CA
;; copyright (c) 1986-2001 Franz Inc, Berkeley, CA - All rights reserved.
;;
;; This code is free software; you can redistribute it and/or
;; modify it under the terms of the version 2.1 of
;; the GNU Lesser General Public License as published by
;; the Free Software Foundation, as clarified by the Franz
;; preamble to the LGPL found in
;; http://opensource.franz.com/preamble.html.
;;
;; This code is distributed in the hope that it will be useful,
;; but without any warranty; without even the implied warranty of
;; merchantability or fitness for a particular purpose.  See the GNU
;; Lesser General Public License for more details.
;;
;; Version 2.1 of the GNU Lesser General Public License can be
;; found at http://opensource.franz.com/license.html.
;; If it is not present, you can access it from
;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
;; version) or write to the Free Software Foundation, Inc., 59 Temple
;; Place, Suite 330, Boston, MA  02111-1307  USA
;;
;;;; from the original ACL 6.1 sources:
;; $Id: acl-compat-tester.cl,v 1.2 2002/04/19 20:25:20 marc.battyani Exp $

(defpackage :util.test
  (:use :common-lisp)
  (:shadow #:test)
  (:export
;;;; Control variables:
   #:*break-on-test-failures*
   #:*error-protect-tests*
   #:*test-errors*
   #:*test-successes*
   #:*test-unexpected-failures*

;;;; The test macros:
   #:test
   #:test-error
   #:test-no-error
   #:test-warning
   #:test-no-warning

   #:with-tests
   ))

(in-package :util.test)

#-lispworks
(unless (find-class 'break nil)
  (define-condition break (simple-condition) ()))

(define-condition simple-break (error simple-condition) ())

;; the if* macro used in Allegro:
;;
;; This is in the public domain... please feel free to put this definition
;; in your code or distribute it with your version of lisp.

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defvar if*-keyword-list '("then" "thenret" "else" "elseif")))

(defmacro if* (&rest args)
   (do ((xx (reverse args) (cdr xx))
	(state :init)
	(elseseen nil)
	(totalcol nil)
	(lookat nil nil)
	(col nil))
       ((null xx)
	(cond ((eq state :compl)
	       `(cond ,@totalcol))
	      (t (error "if*: illegal form ~s" args))))
       (cond ((and (symbolp (car xx))
		   (member (symbol-name (car xx))
			   if*-keyword-list
			   :test #'string-equal))
	      (setq lookat (symbol-name (car xx)))))

       (cond ((eq state :init)
	      (cond (lookat (cond ((string-equal lookat "thenret")
				   (setq col nil
					 state :then))
				  (t (error
				      "if*: bad keyword ~a" lookat))))
		    (t (setq state :col
			     col nil)
		       (push (car xx) col))))
	     ((eq state :col)
	      (cond (lookat
		     (cond ((string-equal lookat "else")
			    (cond (elseseen
				   (error
				    "if*: multiples elses")))
			    (setq elseseen t)
			    (setq state :init)
			    (push `(t ,@col) totalcol))
			   ((string-equal lookat "then")
			    (setq state :then))
			   (t (error "if*: bad keyword ~s"
					      lookat))))
		    (t (push (car xx) col))))
	     ((eq state :then)
	      (cond (lookat
		     (error
		      "if*: keyword ~s at the wrong place " (car xx)))
		    (t (setq state :compl)
		       (push `(,(car xx) ,@col) totalcol))))
	     ((eq state :compl)
	      (cond ((not (string-equal lookat "elseif"))
		     (error "if*: missing elseif clause ")))
	      (setq state :init)))))

(defvar *break-on-test-failures* nil
  "When a test failure occurs, common-lisp:break is called, allowing
interactive debugging of the failure.")

(defvar *test-errors* 0
  "The value is the number of test errors which have occurred.")
(defvar *test-successes* 0
  "The value is the number of test successes which have occurred.")
(defvar *test-unexpected-failures* 0
  "The value is the number of unexpected test failures which have occurred.")

(defvar *error-protect-tests* nil
  "Protect each test from errors.  If an error occurs, then that will be
taken as a test failure unless test-error is being used.")

(defmacro test-values-errorset (form &optional announce catch-breaks)
  ;; internal macro
  (let ((g-announce (gensym))
	(g-catch-breaks (gensym)))
    `(let* ((,g-announce ,announce)
	    (,g-catch-breaks ,catch-breaks))
       (handler-case (cons t (multiple-value-list ,form))
	 (condition (condition)
	   (if* (and (null ,g-catch-breaks)
		     (typep condition 'simple-break))
	      then (break condition)
	    elseif ,g-announce
	      then (format *error-output* "~&Condition type: ~a~%"
			   (class-of condition))
		   (format *error-output* "~&Message: ~a~%" condition))
	   condition)))))

(defmacro test-values (form &optional announce catch-breaks)
  ;; internal macro
  (if* *error-protect-tests*
     then `(test-values-errorset ,form ,announce ,catch-breaks)
     else `(cons t (multiple-value-list ,form))))

(defmacro test (expected-value test-form
		&key (test #'eql test-given)
		     (multiple-values nil multiple-values-given)
		     (fail-info nil fail-info-given)
		     (known-failure nil known-failure-given)

;;;;;;;;;; internal, undocumented keywords:
;;;; Note about these keywords: if they were documented, we'd have a
;;;; problem, since they break the left-to-right order of evaluation.
;;;; Specifically, errorset breaks it, and I don't see any way around
;;;; that.  `errorset' is used by the old test.cl module (eg,
;;;; test-equal-errorset).
		     errorset
		     reported-form
		     (wanted-message nil wanted-message-given)
		     (got-message nil got-message-given))
  "Perform a single test.  `expected-value' is the reference value for the
test.  `test-form' is a form that will produce the value to be compared to
the expected-value.  If the values are not the same, then an error is
logged, otherwise a success is logged.

Normally the comparison of values is done with `eql'.  The `test' keyword
argument can be used to specify other comparison functions, such as eq,
equal,equalp, string=, string-equal, etc.

Normally, only the first return value from the test-form is considered,
however if `multiple-values' is t, then all values returned from test-form
are considered.

`fail-info' allows more information to be printed with a test failure.

`known-failure' marks the test as a known failure.  This allows for
programs that do regression analysis on the output from a test run to
discriminate on new versus known failures."
  `(test-check
    :expected-result ,expected-value
    :test-results
    (,(if errorset 'test-values-errorset 'test-values) ,test-form t)
    ,@(when test-given `(:predicate ,test))
    ,@(when multiple-values-given `(:multiple-values ,multiple-values))
    ,@(when fail-info-given `(:fail-info ,fail-info))
    ,@(when known-failure-given `(:known-failure ,known-failure))
    :test-form ',(if reported-form reported-form test-form)
    ,@(when wanted-message-given `(:wanted-message ,wanted-message))
    ,@(when got-message-given `(:got-message ,got-message))))

(defmethod conditionp ((thing condition)) t)
(defmethod conditionp ((thing t)) nil)

(defmacro test-error (form &key announce
				catch-breaks
				(fail-info nil fail-info-given)
				(known-failure nil known-failure-given)
				(condition-type ''simple-error)
				(include-subtypes nil include-subtypes-given)
				(format-control nil format-control-given)
				(format-arguments nil format-arguments-given))
  "Test that `form' signals an error. The order of evaluation of the
arguments is keywords first, then test form.

If `announce' is non-nil, then cause the error message to be printed.

The `catch-breaks' is non-nil then consider a call to common-lisp:break an
`error'.

`fail-info' allows more information to be printed with a test failure.

`known-failure' marks the test as a known failure.  This allows for
programs that do regression analysis on the output from a test run to
discriminate on new versus known failures.

If `condition-type' is non-nil, it should be a symbol naming a condition
type, which is used to check against the signalled condition type.  The
test will fail if they do not match.

`include-subtypes', used with `condition-type', can be used to match a
condition to an entire subclass of the condition type hierarchy.

`format-control' and `format-arguments' can be used to check the error
message itself."
  (let ((g-announce (gensym))
	(g-catch-breaks (gensym))
	(g-fail-info (gensym))
	(g-known-failure (gensym))
	(g-condition-type (gensym))
	(g-include-subtypes (gensym))
	(g-format-control (gensym))
	(g-format-arguments (gensym))
	(g-c (gensym)))
    `(let* ((,g-announce ,announce)
	    (,g-catch-breaks ,catch-breaks)
	    ,@(when fail-info-given `((,g-fail-info ,fail-info)))
	    ,@(when known-failure-given `((,g-known-failure ,known-failure)))
	    (,g-condition-type ,condition-type)
	    ,@(when include-subtypes-given
		`((,g-include-subtypes ,include-subtypes)))
	    ,@(when format-control-given
		`((,g-format-control ,format-control)))
	    ,@(when format-arguments-given
		`((,g-format-arguments ,format-arguments)))
	    (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
       (test-check
	:predicate #'eq
	:expected-result t
	:test-results
	(test-values (and (conditionp ,g-c)
			  ,@(if* include-subtypes-given
			       then `((if* ,g-include-subtypes
					 then (typep ,g-c ,g-condition-type)
					 else (eq (class-of ,g-c)
						  (find-class
						   ,g-condition-type))))
			       else `((eq (class-of ,g-c)
					  (find-class ,g-condition-type))))
			  ,@(when format-control-given
			      `((or
				 (null ,g-format-control)
				 (string=
				  (concatenate 'simple-string
				    "~1@<" ,g-format-control "~:@>")
				  (simple-condition-format-control ,g-c)))))
			  ,@(when format-arguments-given
			      `((or
				 (null ,g-format-arguments)
				 (equal
				  ,g-format-arguments
				  (simple-condition-format-arguments ,g-c))))))
		     t)
	:test-form ',form
	,@(when fail-info-given `(:fail-info ,g-fail-info))
	,@(when known-failure-given `(:known-failure ,g-known-failure))
	:condition-type ,g-condition-type
	:condition ,g-c
	,@(when include-subtypes-given
	    `(:include-subtypes ,g-include-subtypes))
	,@(when format-control-given
	    `(:format-control ,g-format-control))
	,@(when format-arguments-given
	    `(:format-arguments ,g-format-arguments))))))

(defmacro test-no-error (form &key announce
				   catch-breaks
				   (fail-info nil fail-info-given)
				   (known-failure nil known-failure-given))
  "Test that `form' does not signal an error.  The order of evaluation of
the arguments is keywords first, then test form.

If `announce' is non-nil, then cause the error message to be printed.

The `catch-breaks' is non-nil then consider a call to common-lisp:break an
`error'.

`fail-info' allows more information to be printed with a test failure.

`known-failure' marks the test as a known failure.  This allows for
programs that do regression analysis on the output from a test run to
discriminate on new versus known failures."
  (let ((g-announce (gensym))
	(g-catch-breaks (gensym))
	(g-fail-info (gensym))
	(g-known-failure (gensym))
	(g-c (gensym)))
    `(let* ((,g-announce ,announce)
	    (,g-catch-breaks ,catch-breaks)
	    ,@(when fail-info-given `((,g-fail-info ,fail-info)))
	    ,@(when known-failure-given `((,g-known-failure ,known-failure)))
	    (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
       (test-check
	:predicate #'eq
	:expected-result t
	:test-results (test-values (not (conditionp ,g-c)))
	:test-form ',form
	:condition ,g-c
	,@(when fail-info-given `(:fail-info ,g-fail-info))
	,@(when known-failure-given `(:known-failure ,g-known-failure))))))

(defvar *warn-cookie* (cons nil nil))

(defmacro test-warning (form &key fail-info known-failure)
  "Test that `form' signals a warning.  The order of evaluation of
the arguments is keywords first, then test form.

`fail-info' allows more information to be printed with a test failure.

`known-failure' marks the test as a known failure.  This allows for
programs that do regression analysis on the output from a test run to
discriminate on new versus known failures."
  (let ((g-fail-info (gensym))
	(g-known-failure (gensym))
	(g-value (gensym)))
    `(let* ((,g-fail-info ,fail-info)
	    (,g-known-failure ,known-failure)
	    (,g-value (test-values-errorset ,form nil t)))
       (test
	*warn-cookie*
	(if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
	   then *warn-cookie*
	   else ;; test produced no warning
		nil)
	:test #'eq
	:reported-form ,form ;; quoted by test macro
	:wanted-message "a warning"
	:got-message "no warning"
	:fail-info ,g-fail-info
	:known-failure ,g-known-failure))))

(defmacro test-no-warning (form &key fail-info known-failure)
  "Test that `form' does not signal a warning.  The order of evaluation of
the arguments is keywords first, then test form.

`fail-info' allows more information to be printed with a test failure.

`known-failure' marks the test as a known failure.  This allows for
programs that do regression analysis on the output from a test run to
discriminate on new versus known failures."
  (let ((g-fail-info (gensym))
	(g-known-failure (gensym))
	(g-value (gensym)))
    `(let* ((,g-fail-info ,fail-info)
	    (,g-known-failure ,known-failure)
	    (,g-value (test-values-errorset ,form nil t)))
       (test
	*warn-cookie*
	(if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
	   then nil ;; test produced warning
	   else *warn-cookie*)
	:test #'eq
	:reported-form ',form
	:wanted-message "no warning"
	:got-message "a warning"
	:fail-info ,g-fail-info
	:known-failure ,g-known-failure))))

(defvar *announce-test* nil) ;; if true announce each test that was done

(defmacro errorset (form &optional announce catch-breaks)
  ;; Evaluate FORM, and if there are no errors and FORM returns
  ;; values v1,v2,...,vn, then return values t,v1,v2,...,vn.  If an
  ;; error occurs while evaluating FORM, then return nil immediately.
  ;; If ANNOUNCE is t, then the error message will be printed out.
  (if catch-breaks
      `(handler-case (values-list (cons t (multiple-value-list ,form)))
         (error (condition)
           (declare (ignore-if-unused condition))
           ,@(if announce `((format *error-output* "~&Error: ~a~%" condition)))
           nil)
         (simple-break (condition)
           (declare (ignore-if-unused condition))
           ,@(if announce `((format *error-output* "~&Warning: ~a~%" condition))
)
           nil))
    `(handler-case (values-list (cons t (multiple-value-list ,form)))
       (error (condition)
         (declare (ignore-if-unused condition))
         ,@(if announce `((format *error-output* "~&Error: ~a~%" condition)))
         nil))))

(defun test-check (&key (predicate #'eql)
			expected-result test-results test-form
			multiple-values fail-info known-failure
			wanted-message got-message condition-type condition
			include-subtypes format-control format-arguments
		   &aux fail predicate-failed got wanted)
  ;; for debugging large/complex test sets:
  (when *announce-test*
    (format t "Just did test ~s~%" test-form)
    (force-output))

  ;; this is an internal function
  (flet ((check (expected-result result)
	   (let* ((results
		   (multiple-value-list
		    (errorset (funcall predicate expected-result result) t)))
		  (failed (null (car results))))
	     (if* failed
		then (setq predicate-failed t)
		     nil
		else (cadr results)))))
    (when (conditionp test-results)
      (setq condition test-results)
      (setq test-results nil))
    (when (null (car test-results))
      (setq fail t))
    (if* (and (not fail) (not multiple-values))
       then ;; should be a single result
	    ;; expected-result is the single result wanted
	    (when (not (and (cdr test-results)
			    (check expected-result (cadr test-results))))
	      (setq fail t))
	    (when (and (not fail) (cddr test-results))
	      (setq fail 'single-got-multiple))
       else ;; multiple results wanted
	    ;; expected-result is a list of results, each of which
	    ;; should be checked against the corresponding test-results
	    ;; using the predicate
	    (do ((got (cdr test-results) (cdr got))
		 (want expected-result (cdr want)))
		((or (null got) (null want))
		 (when (not (and (null want) (null got)))
		   (setq fail t)))
	      (when (not (check (car got) (car want)))
		(return (setq fail t)))))
    (if* fail
       then (when (not known-failure)
	      (format *error-output*
		      "~& * * * UNEXPECTED TEST FAILURE * * *~%")
	      (incf *test-unexpected-failures*))
	    (format *error-output* "~&Test failed: ~@[known failure: ~*~]~s~%"
		    known-failure test-form)
	    (if* (eq 'single-got-multiple fail)
	       then (format
		     *error-output*
		     "~
Reason: additional value were returned from test form.~%")
	     elseif predicate-failed
	       then (format *error-output* "Reason: predicate error.~%")
	     elseif (null (car test-results))
	       then (format *error-output* "~
Reason: an error~@[ (of type `~s')~] was detected.~%"
			    (when condition (class-of condition)))
	     elseif condition
	       then (if* (not (conditionp condition))
		       then (format *error-output* "~
Reason: expected but did not detect an error of type `~s'.~%"
				    condition-type)
		     elseif (null condition-type)
		       then (format *error-output* "~
Reason: detected an unexpected error of type `~s':
        ~a.~%"
				    (class-of condition)
				    condition)
		     elseif (not (if* include-subtypes
				    then (typep condition condition-type)
				    else (eq (class-of condition)
					     (find-class condition-type))))
		       then (format *error-output* "~
Reason: detected an incorrect condition type.~%")
			    (format *error-output*
				    "  wanted: ~s~%" condition-type)
			    (format *error-output*
				    "     got: ~s~%" (class-of condition))
		     elseif (and format-control
				 (not (string=
				       (setq got
					 (concatenate 'simple-string
					   "~1@<" format-control "~:@>"))
				       (setq wanted
					 (simple-condition-format-control
					  condition)))))
		       then ;; format control doesn't match
			    (format *error-output* "~
Reason: the format-control was incorrect.~%")
			    (format *error-output* "  wanted: ~s~%" wanted)
			    (format *error-output* "     got: ~s~%" got)
		     elseif (and format-arguments
				 (not (equal
				       (setq got format-arguments)
				       (setq wanted
					 (simple-condition-format-arguments
					  condition)))))
		       then (format *error-output* "~
Reason: the format-arguments were incorrect.~%")
			    (format *error-output* "  wanted: ~s~%" wanted)
			    (format *error-output* "     got: ~s~%" got)
		       else ;; what else????
			    (error "internal-error"))
	       else (let ((*print-length* 50)
			  (*print-level* 10))
		      (if* wanted-message
			 then (format *error-output*
				      "  wanted: ~a~%" wanted-message)
			 else (if* (not multiple-values)
				 then (format *error-output*
					      "  wanted: ~s~%"
					      expected-result)
				 else (format
				       *error-output*
				       "  wanted values: ~{~s~^, ~}~%"
				       expected-result)))
		      (if* got-message
			 then (format *error-output*
				      "     got: ~a~%" got-message)
			 else (if* (not multiple-values)
				 then (format *error-output* "     got: ~s~%"
				       (second test-results))
				 else (format
				       *error-output*
				       "     got values: ~{~s~^, ~}~%"
				       (cdr test-results))))))
	    (when fail-info
	      (format *error-output* "Additional info: ~a~%" fail-info))
	    (incf *test-errors*)
	    (when *break-on-test-failures*
	      (break "~a is non-nil." '*break-on-test-failures*))
       else (when known-failure
	      (format *error-output*
		      "~&Expected test failure for ~s did not occur.~%"
		      test-form)
	      (when fail-info
		(format *error-output* "Additional info: ~a~%" fail-info))
	      (setq fail t))
	    (incf *test-successes*))
    (not fail)))

(defmacro with-tests ((&key (name "unnamed")) &body body)
  (let ((g-name (gensym)))
    `(flet ((doit () ,@body))
       (let ((,g-name ,name)
	     (*test-errors* 0)
	     (*test-successes* 0)
	     (*test-unexpected-failures* 0))
	 (format *error-output* "Begin ~a test~%" ,g-name)
	 (if* *break-on-test-failures*
	    then (doit)
	    else (handler-case (doit)
		   (error (c)
		     (format
		      *error-output*
		      "~
~&Test ~a aborted by signalling an uncaught error:~%~a~%"
		      ,g-name c))))
	 #+allegro
	 (let ((state (sys:gsgc-switch :print)))
	   (setf (sys:gsgc-switch :print) nil)
	   (format t "~&**********************************~%" ,g-name)
	   (format t "End ~a test~%" ,g-name)
	   (format t "Errors detected in this test: ~s " *test-errors*)
	   (unless (zerop *test-unexpected-failures*)
	     (format t "UNEXPECTED: ~s" *test-unexpected-failures*))
	   (format t "~%Successes this test:~s~%" *test-successes*)
	   (setf (sys:gsgc-switch :print) state))
	 #-allegro
	 (progn
	   (format t "~&**********************************~%" ,g-name)
	   (format t "End ~a test~%" ,g-name)
	   (format t "Errors detected in this test: ~s " *test-errors*)
	   (unless (zerop *test-unexpected-failures*)
	     (format t "UNEXPECTED: ~s" *test-unexpected-failures*))
	   (format t "~%Successes this test:~s~%" *test-successes*))
	 ))))

(provide :tester #+module-versions 1.1)