view src/glyphs-shared.c @ 4678:b5e1d4f6b66f

Make #'floor, #'ceiling, #'round, #'truncate conform to Common Lisp. lisp/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea@parhasard.net> * cl-extra.el (ceiling*, floor*, round*, truncate*): Implement these in terms of the C functions; mark them as obsolete. (mod*, rem*): Use #'nth-value with the C functions, not #'nth with the CL emulation functions. man/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea@parhasard.net> * lispref/numbers.texi (Bigfloat Basics): Correct this documentation (ignoring for the moment that it breaks off in mid-sentence). tests/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea@parhasard.net> * automated/lisp-tests.el: Test the new Common Lisp-compatible rounding functions available in C. (generate-rounding-output): Provide a function useful for generating the data for the rounding functions tests. src/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea@parhasard.net> * floatfns.c (ROUNDING_CONVERT, CONVERT_WITH_NUMBER_TYPES) (CONVERT_WITHOUT_NUMBER_TYPES, MAYBE_TWO_ARGS_BIGNUM) (MAYBE_ONE_ARG_BIGNUM, MAYBE_TWO_ARGS_RATIO) (MAYBE_ONE_ARG_RATIO, MAYBE_TWO_ARGS_BIGFLOAT) (MAYBE_ONE_ARG_BIGFLOAT, MAYBE_EFF, MAYBE_CHAR_OR_MARKER): New macros, used in the implementation of the rounding functions. (ceiling_two_fixnum, ceiling_two_bignum, ceiling_two_ratio) (ceiling_two_bigfloat, ceiling_one_ratio, ceiling_one_bigfloat) (ceiling_two_float, ceiling_one_float, ceiling_one_mundane_arg) (floor_two_fixnum, floor_two_bignum, floor_two_ratio) (floor_two_bigfloat, floor_one_ratio, floor_one_bigfloat) (floor_two_float, floor_one_mundane_arg, round_two_fixnum) (round_two_bignum_1, round_two_bignum, round_two_ratio) (round_one_bigfloat_1, round_two_bigfloat, round_one_ratio) (round_one_bigfloat, round_two_float, round_one_float) (round_one_mundane_arg, truncate_two_fixnum) (truncate_two_bignum, truncate_two_ratio, truncate_two_bigfloat) (truncate_one_ratio, truncate_one_bigfloat, truncate_two_float) (truncate_one_float, truncate_one_mundane_arg): New functions, used in the implementation of the rounding functions. (Fceiling, Ffloor, Fround, Ftruncate, Ffceiling, Fffloor) (Ffround, Fftruncate): Revise to fully support Common Lisp conventions. This means: -- All functions have optional DIVISOR arguments -- All functions return multiple values; see #'values -- All functions do their arithmetic with the correct number types according to the contamination rules. -- #'round and #'fround always round towards the even number in ambiguous cases. * doprnt.c (emacs_doprnt_1): * number.c (internal_coerce_number): Call Ftruncate with two arguments, not one. * floatfns.c (Ffloat): Correct this, if NUMBER is a bignum. * lisp.h: Declare Ftruncate as taking two arguments. * number.c: Provide scratch_ratio2, init it appropriately. * number.h: Make scratch_ratio2 available. * number.h (BIGFLOAT_ARITH_RETURN): * number.h (BIGFLOAT_ARITH_RETURN1): Correct these functions.
author Aidan Kehoe <kehoea@parhasard.net>
date Tue, 11 Aug 2009 17:59:23 +0100
parents 9b4442ac18c7
children b3ea9c582280
line wrap: on
line source

/* Routines shared between window-system backends for glyph objects.
   Copyright (C) 1993, 1994 Free Software Foundation, Inc.
   Copyright (C) 1995 Board of Trustees, University of Illinois
   Copyright (C) 1995 Tinker Systems
   Copyright (C) 1995, 1996, 2001 Ben Wing
   Copyright (C) 1995 Sun Microsystems
   Copyright (C) 1998, 1999, 2000 Andy Piper

This file is part of XEmacs.

XEmacs is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the
Free Software Foundation; either version 2, or (at your option) any
later version.

XEmacs 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 General Public License
for more details.

You should have received a copy of the GNU General Public License
along with XEmacs; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.  */

/* Synched up with: Not in FSF. */

/* taken from glyphs-*.c
   HINT HINT HINT Bill Perry: Please put code here and avoid massive
   duplication in *-gtk.c!!! */

#include <config.h>
#include "lisp.h"

#include "buffer.h"
#include "elhash.h"
#include "faces.h"
#include "frame.h"
#include "glyphs.h"
#include "imgproc.h"
#include "insdel.h"
#include "lstream.h"
#include "opaque.h"
#include "sysdep.h"
#include "window.h"

#include "sysfile.h"

Lisp_Object Q_resource_type, Q_resource_id;

void
shared_resource_validate (Lisp_Object instantiator)
{
  if ((NILP (find_keyword_in_vector (instantiator, Q_file))
       &&
       NILP (find_keyword_in_vector (instantiator, Q_resource_id)))
      ||
      NILP (find_keyword_in_vector (instantiator, Q_resource_type)))
    sferror ("Must supply :file, :resource-id and :resource-type",
	     instantiator);
}


Lisp_Object
shared_resource_normalize (Lisp_Object inst, Lisp_Object console_type,
			   Lisp_Object UNUSED (dest_mask), Lisp_Object tag)
{
  /* This function can call lisp */
  Lisp_Object file = Qnil;
  struct gcpro gcpro1, gcpro2;
  Lisp_Object alist = Qnil;

  GCPRO2 (file, alist);

  file = potential_pixmap_file_instantiator (inst, Q_file, Q_data,
					     console_type);

  if (NILP (file)) /* normalization impossible for the console type */
    RETURN_UNGCPRO (Qnil);

  if (CONSP (file)) /* failure locating filename */
    signal_double_image_error ("Opening pixmap file",
			       "no such file or directory",
			       Fcar (file));

  if (EQ (file, Qt)) /* no conversion necessary */
    RETURN_UNGCPRO (inst);

  alist = tagged_vector_to_alist (inst);

  {
    alist = remassq_no_quit (Q_file, alist);
    alist = Fcons (Fcons (Q_file, file), alist);
  }

  {
    Lisp_Object result = alist_to_tagged_vector (tag, alist);
    free_alist (alist);
    RETURN_UNGCPRO (result);
  }
}

/* Originally from xmu.c, but is now shared across X11, GTK, and MSW. */
/*
 * Based on an optimized version provided by Jim Becker, August 5, 1988.
 */


#ifndef BitmapSuccess
#define BitmapSuccess           0
#define BitmapOpenFailed        1
#define BitmapFileInvalid       2
#define BitmapNoMemory          3
#endif

#define MAX_SIZE 255

/* shared data for the image read/parse logic */
static short hexTable[256];		/* conversion value */
static int hex_initialized;	/* easier to fill in at run time */


/*
 *	Table index for the hex values. Initialized once, first time.
 *	Used for translation value or delimiter significance lookup.
 */
static void initHexTable (void)
{
    /*
     * We build the table at run time for several reasons:
     *
     *     1.  portable to non-ASCII machines.
     *     2.  still reentrant since we set the init flag after setting table.
     *     3.  easier to extend.
     *     4.  less prone to bugs.
     */
    hexTable['0'] = 0;	hexTable['1'] = 1;
    hexTable['2'] = 2;	hexTable['3'] = 3;
    hexTable['4'] = 4;	hexTable['5'] = 5;
    hexTable['6'] = 6;	hexTable['7'] = 7;
    hexTable['8'] = 8;	hexTable['9'] = 9;
    hexTable['A'] = 10;	hexTable['B'] = 11;
    hexTable['C'] = 12;	hexTable['D'] = 13;
    hexTable['E'] = 14;	hexTable['F'] = 15;
    hexTable['a'] = 10;	hexTable['b'] = 11;
    hexTable['c'] = 12;	hexTable['d'] = 13;
    hexTable['e'] = 14;	hexTable['f'] = 15;

    /* delimiters of significance are flagged w/ negative value */
    hexTable[' '] = -1;	hexTable[','] = -1;
    hexTable['}'] = -1;	hexTable['\n'] = -1;
    hexTable['\t'] = -1;

    hex_initialized = 1;
}

/*
 *	read next hex value in the input stream, return -1 if EOF
 */
static int NextInt (FILE *fstream)
{
    int	ch;
    int	value = 0;
    int gotone = 0;
    int done = 0;

    /* loop, accumulate hex value until find delimiter  */
    /* skip any initial delimiters found in read stream */

    while (!done) {
	ch = getc(fstream);
	if (ch == EOF) {
	    value	= -1;
	    done++;
	} else {
	    /* trim high bits, check type and accumulate */
	    ch &= 0xff;
	    if (isascii(ch) && isxdigit(ch)) {
		value = (value << 4) + hexTable[ch];
		gotone++;
	    } else if ((hexTable[ch]) < 0 && gotone)
	      done++;
	}
    }
    return value;
}


/*
 * The data returned by the following routine is always in left-most byte
 * first and left-most bit first.  If it doesn't return BitmapSuccess then
 * its arguments won't have been touched.  This routine should look as much
 * like the Xlib routine XReadBitmapfile as possible.
 */
static int
read_bitmap_data (FILE *fstream, int *width, int *height, Binbyte **datap,
		  int *x_hot, int *y_hot)
{
    Binbyte *data = NULL;		/* working variable */
    Ascbyte line[MAX_SIZE];		/* input line from file */
    int size;				/* number of bytes of data */
    Ascbyte name_and_type[MAX_SIZE];	/* an input line */
    Ascbyte *type;			/* for parsing */
    int value;				/* from an input line */
    int version10p;			/* boolean, old format */
    int padding;			/* to handle alignment */
    int bytes_per_line;			/* per scanline of data */
    int ww = 0;				/* width */
    int hh = 0;				/* height */
    int hx = -1;			/* x hotspot */
    int hy = -1;			/* y hotspot */

#ifndef Xmalloc
#define Xmalloc(size) malloc(size)
#endif

    /* first time initialization */
    if (!hex_initialized) initHexTable();

    /* error cleanup and return macro	*/
#define	RETURN(code) { if (data) free (data); return code; }

    while (fgets(line, MAX_SIZE, fstream)) {
	if (strlen(line) == MAX_SIZE-1) {
	    RETURN (BitmapFileInvalid);
	}
	if (sscanf(line,"#define %s %d",name_and_type,&value) == 2) {
	    if (!(type = strrchr(name_and_type, '_')))
	      type = name_and_type;
	    else
	      type++;

	    if (!strcmp("width", type))
	      ww = value;
	    if (!strcmp("height", type))
	      hh = value;
	    if (!strcmp("hot", type)) {
		if (type-- == name_and_type || type-- == name_and_type)
		  continue;
		if (!strcmp("x_hot", type))
		  hx = value;
		if (!strcmp("y_hot", type))
		  hy = value;
	    }
	    continue;
	}

	if (sscanf(line, "static short %s = {", name_and_type) == 1)
	  version10p = 1;
	else if (sscanf(line,"static unsigned char %s = {",name_and_type) == 1)
	  version10p = 0;
	else if (sscanf(line, "static char %s = {", name_and_type) == 1)
	  version10p = 0;
	else
	  continue;

	if (!(type = strrchr(name_and_type, '_')))
	  type = name_and_type;
	else
	  type++;

	if (strcmp("bits[]", type))
	  continue;

	if (!ww || !hh)
	  RETURN (BitmapFileInvalid);

	if ((ww % 16) && ((ww % 16) < 9) && version10p)
	  padding = 1;
	else
	  padding = 0;

	bytes_per_line = (ww+7)/8 + padding;

	size = bytes_per_line * hh;
	data = (Binbyte *) Xmalloc ((unsigned int) size);
	if (!data)
	  RETURN (BitmapNoMemory);

	if (version10p) {
	    Binbyte *ptr;
	    int bytes;

	    for (bytes=0, ptr=data; bytes<size; (bytes += 2)) {
		if ((value = NextInt(fstream)) < 0)
		  RETURN (BitmapFileInvalid);
		*(ptr++) = value;
		if (!padding || ((bytes+2) % bytes_per_line))
		  *(ptr++) = value >> 8;
	    }
	} else {
	    Binbyte *ptr;
	    int bytes;

	    for (bytes=0, ptr=data; bytes<size; bytes++, ptr++) {
		if ((value = NextInt(fstream)) < 0)
		  RETURN (BitmapFileInvalid);
		*ptr=value;
	    }
	}
	break;
    }					/* end while */

    if (data == NULL) {
	RETURN (BitmapFileInvalid);
    }

    *datap = data;
    data = NULL;
    *width = ww;
    *height = hh;
    if (x_hot) *x_hot = hx;
    if (y_hot) *y_hot = hy;

    RETURN (BitmapSuccess);
}


int
read_bitmap_data_from_file (Lisp_Object filename,
			    /* Remaining args are RETURNED */
			    int *width,
			    int *height,
			    Binbyte **datap,
			    int *x_hot, int *y_hot)
{
  FILE *fstream;
  int status;
  Extbyte *fileext;

  LISP_STRING_TO_EXTERNAL (filename, fileext, Qnative);
  if ((fstream = fopen (fileext, "r")) == NULL)
    return BitmapOpenFailed;
  status = read_bitmap_data (fstream, width, height, datap, x_hot, y_hot);
  retry_fclose (fstream);
  return status;
}

void
syms_of_glyphs_shared (void)
{
  DEFKEYWORD (Q_resource_id);
  DEFKEYWORD (Q_resource_type);
}