view src/libsst.c @ 4677:8f1ee2d15784

Support full Common Lisp multiple values in C. lisp/ChangeLog 2009-08-11 Aidan Kehoe <kehoea@parhasard.net> * bytecomp.el : Update this file to support full C-level multiple values. This involves: -- Four new bytecodes, and special compiler functions to compile multiple-value-call, multiple-value-list-internal, values, values-list, and, since it now needs to pass back multiple values and is a special form, throw. -- There's a new compiler variable, byte-compile-checks-on-load, which is a list of forms that are evaluated at the very start of a file, with an error thrown if any of them give nil. -- The header is now inserted *after* compilation, giving a chance for the compilation process to influence what those checks are. There is still a check done before compilation for non-ASCII characters, to try to turn off dynamic docstrings if appopriate, in `byte-compile-maybe-reset-coding'. Space is reserved for checks; comments describing the version of the byte compiler generating the file are inserted if space remains for them. * bytecomp.el (byte-compile-version): Update this, we're a newer version of the byte compiler. * byte-optimize.el (byte-optimize-funcall): Correct a comment. * bytecomp.el (byte-compile-lapcode): Discard the arg with byte-multiple-value-call. * bytecomp.el (byte-compile-checks-and-comments-space): New variable, describe how many octets to reserve for checks at the start of byte-compiled files. * cl-compat.el: Remove the fake multiple-value implementation. Have the functions that use it use the real multiple-value implementation instead. * cl-macs.el (cl-block-wrapper, cl-block-throw): Revise the byte-compile properties of these symbols to work now we've made throw into a special form; keep the byte-compile properties as anonymous lambdas, since we don't have docstrings for them. * cl-macs.el (multiple-value-bind, multiple-value-setq) (multiple-value-list, nth-value): Update these functions to work with the C support for multiple values. * cl-macs.el (values): Modify the setf handler for this to call #'multiple-value-list-internal appropriately. * cl-macs.el (cl-setf-do-store): If the store form is a cons, treat it specially as wrapping the store value. * cl.el (cl-block-wrapper): Make this an alias of #'and, not #'identity, since it needs to pass back multiple values. * cl.el (multiple-value-apply): We no longer support this, mark it obsolete. * lisp-mode.el (eval-interactive-verbose): Remove a useless space in the docstring. * lisp-mode.el (eval-interactive): Update this function and its docstring. It now passes back a list, basically wrapping any eval calls with multiple-value-list. This allows multiple values to be printed by default in *scratch*. * lisp-mode.el (prin1-list-as-multiple-values): New function, printing a list as multiple values in the manner of Bruno Haible's clisp, separating each entry with " ;\n". * lisp-mode.el (eval-last-sexp): Call #'prin1-list-as-multiple-values on the return value of #'eval-interactive. * lisp-mode.el (eval-defun): Call #'prin1-list-as-multiple-values on the return value of #'eval-interactive. * mouse.el (mouse-eval-sexp): Deal with lists corresponding to multiple values from #'eval-interactive. Call #'cl-prettyprint, which is always available, instead of sometimes calling #'pprint and sometimes falling back to prin1. * obsolete.el (obsolete-throw): New function, called from eval.c when #'funcall encounters an attempt to call #'throw (now a special form) as a function. Only needed for compatibility with 21.4 byte-code. man/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea@parhasard.net> * cl.texi (Organization): Remove references to the obsolete multiple-value emulating code. src/ChangeLog addition: 2009-08-11 Aidan Kehoe <kehoea@parhasard.net> * bytecode.c (enum Opcode /* Byte codes */): Add four new bytecodes, to deal with multiple values. (POP_WITH_MULTIPLE_VALUES): New macro. (POP): Modify this macro to ignore multiple values. (DISCARD_PRESERVING_MULTIPLE_VALUES): New macro. (DISCARD): Modify this macro to ignore multiple values. (TOP_WITH_MULTIPLE_VALUES): New macro. (TOP_ADDRESS): New macro. (TOP): Modify this macro to ignore multiple values. (TOP_LVALUE): New macro. (Bcall): Ignore multiple values where appropriate. (Breturn): Pass back multiple values. (Bdup): Preserve multiple values. Use TOP_LVALUE with most bytecodes that assign anything to anything. (Bbind_multiple_value_limits, Bmultiple_value_call, Bmultiple_value_list_internal, Bthrow): Implement the new bytecodes. (Bgotoifnilelsepop, Bgotoifnonnilelsepop, BRgotoifnilelsepop, BRgotoifnonnilelsepop): Discard any multiple values. * callint.c (Fcall_interactively): Ignore multiple values when calling #'eval, in two places. * device-x.c (x_IO_error_handler): * macros.c (pop_kbd_macro_event): * eval.c (Fsignal): * eval.c (flagged_a_squirmer): Call throw_or_bomb_out, not Fthrow, now that the latter is a special form. * eval.c: Make Qthrow, Qobsolete_throw available as symbols. Provide multiple_value_current_limit, multiple-values-limit (the latter as specified by Common Lisp. * eval.c (For): Ignore multiple values when comparing with Qnil, but pass any multiple values back for the last arg. * eval.c (Fand): Ditto. * eval.c (Fif): Ignore multiple values when examining the result of the condition. * eval.c (Fcond): Ignore multiple values when comparing what the clauses give, but pass them back if a clause gave non-nil. * eval.c (Fprog2): Never pass back multiple values. * eval.c (FletX, Flet): Ignore multiple when evaluating what exactly symbols should be bound to. * eval.c (Fwhile): Ignore multiple values when evaluating the test. * eval.c (Fsetq, Fdefvar, Fdefconst): Ignore multiple values. * eval.c (Fthrow): Declare this as a special form; ignore multiple values for TAG, preserve them for VALUE. * eval.c (throw_or_bomb_out): Make this available to other files, now Fthrow is a special form. * eval.c (Feval): Ignore multiple values when calling a compiled function, a non-special-form subr, or a lambda expression. * eval.c (Ffuncall): If we attempt to call #'throw (now a special form) as a function, don't error, call #'obsolete-throw instead. * eval.c (make_multiple_value, multiple_value_aset) (multiple_value_aref, print_multiple_value, mark_multiple_value) (size_multiple_value): Implement the multiple_value type. Add a long comment describing our implementation. * eval.c (bind_multiple_value_limits): New function, used by the bytecode and by #'multiple-value-call, #'multiple-value-list-internal. * eval.c (multiple_value_call): New function, used by the bytecode and #'multiple-value-call. * eval.c (Fmultiple_value_call): New special form. * eval.c (multiple_value_list_internal): New function, used by the byte code and #'multiple-value-list-internal. * eval.c (Fmultiple_value_list_internal, Fmultiple_value_prog1): New special forms. * eval.c (Fvalues, Fvalues_list): New Lisp functions. * eval.c (values2): New function, for C code returning multiple values. * eval.c (syms_of_eval): Make our new Lisp functions and symbols available. * eval.c (multiple-values-limit): Make this available to Lisp. * event-msw.c (dde_eval_string): * event-stream.c (execute_help_form): * glade.c (connector): * glyphs-widget.c (glyph_instantiator_to_glyph): * glyphs.c (evaluate_xpm_color_symbols): * gui-x.c (wv_set_evalable_slot, button_item_to_widget_value): * gui.c (gui_item_value, gui_item_display_flush_left): * lread.c (check_if_suppressed): * menubar-gtk.c (menu_convert, menu_descriptor_to_widget_1): * menubar-msw.c (populate_menu_add_item): * print.c (Fwith_output_to_temp_buffer): * symbols.c (Fsetq_default): Ignore multiple values when calling Feval. * symeval.h: Add the header declarations necessary for the multiple-values implementation. * inline.c: #include symeval.h, now that it has some inline functions. * lisp.h: Update Fthrow's declaration. Make throw_or_bomb_out available to all files. * lrecord.h (enum lrecord_type): Add the multiple_value type here.
author Aidan Kehoe <kehoea@parhasard.net>
date Sun, 16 Aug 2009 20:55:49 +0100
parents ecf1ebac70d8
children
line wrap: on
line source

/* libsst.c - SPARC sound tools library
**
** Copyright (C) 1989 by Jef Poskanzer.
**
** Permission to use, copy, modify, and distribute this software and its
** documentation for any purpose and without fee is hereby granted, provided
** that the above copyright notice appear in all copies and that both that
** copyright notice and this permission notice appear in supporting
** documentation.  This software is provided "as is" without express or
** implied warranty.

** Hacked on by jwz for emacs.

*/

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

/* This file Mule-ized by Ben Wing, 5-15-01. */

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

#include "sound.h"

#include "libsst.h"

#include "sysfile.h"


#define AUDBUF 1024

int
sst_open(play_level, record_level)
    int play_level, record_level;
    {
    int fd, i, gr, ger, gx;
    struct audio_ioctl ai;
    Extbyte *ep;

    fd = open ("/dev/audio", O_RDWR);
    if ( fd < 0 )
	{
	sound_perror( "sst_open: open /dev/audio" );
	return( fd );
	}

#ifdef AUDIOSETQSIZE /* This no longer exists as of 4.1.2. */

    /* Shrink audio device's queue size, to cut down time delay. */
    i = AUDBUF;
    if ( ioctl( fd, AUDIOSETQSIZE, &i ) < 0 )
	{
	sound_perror( "sst_open: SETQSIZE" );
	return( fd );
	}
#endif /* AUDIOSETQSIZE */

    /* Set gains.  -10 <= ger <= 18,  -18 <= gr <= 12,  -18 <= gx <= 12. */
    if (!play_level) 
    {
	play_level = 75;
	if ( (ep = egetenv( "SST_PLAY" )) != NULL )
	{
	    play_level = atoi( ep );
	    if ( play_level < 0 || play_level > 99 )
	    {
		sound_warn( "sst_open: SST_PLAY must be between 0 and 99" );
		return( -1 );
	    }
	}
    }
    if (!record_level) 
    {
	record_level = 75;
	if ( (ep = egetenv( "SST_RECORD" )) != NULL )
	{
	    record_level = atoi( ep );
	    if ( record_level < 0 || record_level > 99 )
	    {
		sound_warn( "sst_open: SST_RECORD must be between 0 and 99" );
		return( -1 );
	    }
	}
    }

    play_level = play_level * 59 / 100 - 28;
    ger = play_level / 2;
    gr = play_level - ger;
    if ( ger < -10 )
	{
	ger = -10;
	gr = play_level - ger;
	}
    if ( gr > 12 )
	{
	gr = 12;
	ger = play_level - gr;
	}
    gx = record_level * 31 / 100 - 18;
    sst_set_gr( fd, gr );
    sst_set_ger( fd, ger );
    sst_set_gx( fd, gx );

    /*  Initialize the MMR2 register to send the output to either
    **  the speaker or the earphone jack, depending on SST_EARPHONES.
    */
    ai.control = AUDIO_MAP_MMR2;
    if ( ioctl( fd, AUDIOGETREG, &ai ) < 0 )
	{
	sound_perror( "sst_open: GETREG MMR2" );
	return( -1 );
	}
    if ( (ep = egetenv( "SST_EARPHONES" )) != NULL )
	ai.data[0] &= ~AUDIO_MMR2_BITS_LS;
    else
	ai.data[0] |= AUDIO_MMR2_BITS_LS;
    if ( ioctl( fd, AUDIOSETREG, &ai ) < 0 )
	{
	sound_perror( "sst_open: SETREG MMR2" );
	return( fd );
	}

    return fd;
    }

void
sst_close( fd )
int fd;
    {
    struct audio_ioctl ai;

    ai.control = AUDIO_MAP_MMR1;
    ai.data[0] = 0;
    if ( ioctl( fd, AUDIOSETREG, &ai ) < 0 )
	{
	sound_perror( "sst_close: SETREG MMR1" );
	}
    ai.control = AUDIO_MAP_MMR2;
    ai.data[0] = 0;
    if ( ioctl( fd, AUDIOSETREG, &ai ) < 0 )
	{
	sound_perror( "sst_close: SETREG MMR2" );
	}
    close( fd );
    }

/* These are tables of values to be loaded into various gain registers.
*/

static Binbyte ger_table[][2] = {
    0xaa,	0xaa,	/* -10db */
    0x79,	0xac,
    0x41,	0x99,
    0x9c,	0xde,
    0x74,	0x9c,	/* -6db */
    0x6a,	0xae,
    0xab,	0xdf,
    0x64,	0xab,
    0x2a,	0xbd,
    0x5c,	0xce,
    0x00,	0x99,	/* 0db */
    0x43,	0xdd,
    0x52,	0xef,
    0x55,	0x42,
    0x31,	0xdd,
    0x43,	0x1f,
    0x40,	0xdd,	/* 6db */
    0x44,	0x0f,
    0x31,	0x1f,
    0x10,	0xdd,
    0x41,	0x0f,
    0x60,	0x0b,
    0x42,	0x10,	/* 12db */
    0x11,	0x0f,
    0x72,	0x00,
    0x21,	0x10,
    0x22,	0x00,
    0x00,	0x0b,
    0x00,	0x0f,	/* 18db */
    };


static Binbyte gr_gx_table[][2] = {
    0x8b,	0x7c,	/* -18db */
    0x8b,	0x35,
    0x8b,	0x24,
    0x91,	0x23,
    0x91,	0x2a,
    0x91,	0x3b,
    0x91,	0xf9,	/* -12db */
    0x91,	0xb6,
    0x91,	0xa4,
    0x92,	0x32,
    0x92,	0xaa,
    0x93,	0xb3,
    0x9f,	0x91,	/* -6db */
    0x9b,	0xf9,
    0x9a,	0x4a,
    0xa2,	0xa2,
    0xaa,	0xa3,
    0xbb,	0x52,
    0x08,	0x08,	/* 0db */
    0x3d,	0xac,
    0x25,	0x33,
    0x21,	0x22,
    0x12,	0xa2,
    0x11,	0x3b,
    0x10,	0xf2,	/* 6db */
    0x02,	0xca,
    0x01,	0x5a,
    0x01,	0x12,
    0x00,	0x32,
    0x00,	0x13,
    0x00,	0x0e,	/* 12db */
    };

void
sst_set_ger( fd, value )
int fd, value;
    {
    struct audio_ioctl ai;

    if ( ( value < -10 ) || ( value > 18 ) )
	{
	  Extbyte buf [255];
	  sprintf (buf, "sst_set_ger: GER %d out of range", value);
	  sound_warn(buf);
	  return;
	}

    /*  Add 10 to the value to get the index into the table.  */
    ai.control = AUDIO_MAP_GER;
    ai.data[0] = ger_table[value + 10][1];
    ai.data[1] = ger_table[value + 10][0];

    if ( ioctl( fd, AUDIOSETREG, &ai ) < 0 )
	{
	sound_perror( "sst_set_ger: SETREG GER" );
	}

    ai.control = AUDIO_MAP_MMR1;
    if ( ioctl( fd, AUDIOGETREG, &ai ) < 0 )
	{
	sound_perror( "sst_set_ger: GETREG MMR1" );
	}
    ai.data[0] |= AUDIO_MMR1_BITS_LOAD_GER;
    if ( ioctl( fd, AUDIOSETREG, &ai ) < 0 )
	{
	sound_perror( "sst_set_ger: SETREG MMR1" );
	}
    }

void
sst_set_gr( fd, value )
int fd, value;
    {
    struct audio_ioctl ai;

    if ( ( value < -18 ) || ( value > 12 ) )
	{
	  Extbyte buf [255];
	  sprintf (buf,  "sst_set_gr: GR %d out of range", value);
	  sound_warn (buf);
	  return;
	}

    ai.control = AUDIO_MAP_GR;
    ai.data[0] = gr_gx_table[value + 18][1];
    ai.data[1] = gr_gx_table[value + 18][0];

    if ( ioctl( fd, AUDIOSETREG, &ai ) < 0 )
	{
	sound_perror( "sst_set_gr: SETREG GR" );
	}

    ai.control = AUDIO_MAP_MMR1;
    if ( ioctl( fd, AUDIOGETREG, &ai ) < 0 )
	{
	sound_perror( "sst_set_gr: GETREG MMR1" );
	}
    ai.data[0] |= AUDIO_MMR1_BITS_LOAD_GR;
    if ( ioctl( fd, AUDIOSETREG, &ai ) < 0 )
	{
	sound_perror( "sst_set_gr: SETREG MMR1" );
	}
    }

void
sst_set_gx( fd, value )
int fd, value;
    {
    struct audio_ioctl ai;
    Extbyte buf [255];

    if ( ( value < -18 ) || ( value > 12 ) )
	{
	  sprintf (buf, "sst_set_gx: GX %d out of range", value);
	  sound_warn (buf);
	  return;
	}

    /*  We add 18 to get the index into the table, since entry 0 represents
    *  -18db.
    */
    ai.control = AUDIO_MAP_GX;
    ai.data[0] = gr_gx_table[value + 18][1];
    ai.data[1] = gr_gx_table[value + 18][0];

    if ( ioctl( fd, AUDIOSETREG, &ai ) < 0 )
	{
	sound_perror( "sst_set_gx: SETREG GX" );
	}

    ai.control = AUDIO_MAP_MMR1;
    if ( ioctl( fd, AUDIOGETREG, &ai ) < 0 )
	{
	sound_perror( "sst_set_gx: GETREG MMR1" );
	}
    ai.data[0] |= AUDIO_MMR1_BITS_LOAD_GX;
    if ( ioctl( fd, AUDIOSETREG, &ai ) < 0 )
	{
	sound_perror( "sst_set_gx: SETREG MMR1" );
	}
    }

void
sst_tones( fd, dhz1, dhz2, thz, rhz, usec )
int fd, dhz1, dhz2, thz, rhz, usec;
    {
    Extbyte buf [255];
    struct audio_ioctl ai;
    int dval1, dval2, tval, rval;
    Binbyte oldmmr2, newmmr2;

    if ( dhz1 == 0 )
	dval1 = 0;
    else
	{
	dval1 = ( dhz1 * 128 + 63 ) / 1000;
	if ( ( dval1 < 1 ) || ( dval1 > 255 ) )
	    {
	      sprintf(buf, "sst_tones: dhz1 %d out of range", dhz1 );
	      sound_warn (buf);
	      return;
	    }
	}

    if ( dhz2 == 0 )
	dval2 = 0;
    else
	{
	dval2 = ( dhz2 * 128 + 63 ) / 1000;
	if ( ( dval2 < 1 ) || ( dval2 > 255 ) )
	    {
	      sprintf(buf, "sst_tones: dhz2 %d out of range", dhz2 );
	      sound_warn (buf);
	      return;
	    }
	}

    if ( thz == 0 )
	tval = 0;
    else
	{
	tval = ( thz * 128 + 63 ) / 2000;
	if ( ( tval < 1 ) || ( tval > 255 ) )
	    {
	      sprintf(buf, "sst_tones: thz %d out of range", thz );
	      sound_warn (buf);
	      return;
	    }
	}

    if ( rhz == 0 )
	rval = 0;
    else
	{
	rval = ( rhz * 128 + 63 ) / 2000;
	if ( ( rval < 1 ) || ( rval > 255 ) )
	    {
	      sprintf(buf, "sst_tones: rhz %d out of range", dhz2 );
	      sound_warn (buf);
	      return;
	    }
	}

    if ( ( dval1 != 0 || dval2 != 0 ) && ( tval != 0 || rval != 0 ) )
	{
	  sprintf(buf, "sst_tones: cannot use DTMF and TONE or RINGER at the same time", dhz2 );
	  sound_warn (buf);
	  return;
	}

    if ( tval != 0 && rval != 0 )
	{
	  sprintf(buf, "sst_tones: cannot use TONE and RINGER at the same time", dhz2 );
	  sound_warn (buf);
	return;
	}

    ai.control = AUDIO_MAP_MMR2;
    if ( ioctl( fd, AUDIOGETREG, &ai ) < 0 )
	{
	sound_perror( "sst_tones: GETREG MMR2" );
	}
    oldmmr2 = newmmr2 = ai.data[0];

    if ( dval1 != 0 || dval2 != 0 )
	{
	newmmr2 |= AUDIO_MMR2_BITS_DTMF;
	ai.control = AUDIO_MAP_FTGR;
	ai.data[0] = dval1;
	ai.data[1] = dval2;
	if ( ioctl( fd, AUDIOSETREG, &ai ) < 0 )
	    {
	    sound_perror( "sst_tones: SETREG FTGR" );
	    }
	}

    if ( tval != 0 )
	{
	newmmr2 |= AUDIO_MMR2_BITS_TONE;
	ai.control = AUDIO_MAP_FTGR;
	ai.data[0] = tval;
	ai.data[1] = 0;
	if ( ioctl( fd, AUDIOSETREG, &ai ) < 0 )
	    {
	    sound_perror( "sst_tones: SETREG FTGR" );
	    }
	}

    if ( rval != 0 )
	{
	newmmr2 |= AUDIO_MMR2_BITS_RINGER;
	ai.control = AUDIO_MAP_FTGR;
	ai.data[0] = rval;
	ai.data[1] = 0;
	if ( ioctl( fd, AUDIOSETREG, &ai ) < 0 )
	    {
	    sound_perror( "sst_tones: SETREG FTGR" );
	    }
	}

    ai.control = AUDIO_MAP_MMR2;
    ai.data[0] = newmmr2;
    if ( ioctl( fd, AUDIOSETREG, &ai ) < 0 )
	{
	sound_perror( "sst_tones: SETREG MMR2" );
	}

    usleep( usec );

    ai.data[0] = oldmmr2;
    if ( ioctl( fd, AUDIOSETREG, &ai ) < 0 )
	{
	sound_perror( "sst_tones: SETREG MMR2" );
	}
    }

void
sst_dtmf( fd, dial, usecper, usecpause )
int fd, usecper, usecpause;
Extbyte *dial;
    {
    Extbyte *cp;

    for ( cp = dial; *cp != '\0'; cp++ )
	{
	switch ( *cp )
	    {
	    case '1': sst_tones( fd, 703, 1211, 0, 0, usecper ); break;
	    case '2': sst_tones( fd, 703, 1336, 0, 0, usecper ); break;
	    case '3': sst_tones( fd, 703, 1492, 0, 0, usecper ); break;
	    case 'A': sst_tones( fd, 703, 1648, 0, 0, usecper ); break;
	    case '4': sst_tones( fd, 773, 1211, 0, 0, usecper ); break;
	    case '5': sst_tones( fd, 773, 1336, 0, 0, usecper ); break;
	    case '6': sst_tones( fd, 773, 1492, 0, 0, usecper ); break;
	    case 'B': sst_tones( fd, 773, 1648, 0, 0, usecper ); break;
	    case '7': sst_tones( fd, 859, 1211, 0, 0, usecper ); break;
	    case '8': sst_tones( fd, 859, 1336, 0, 0, usecper ); break;
	    case '9': sst_tones( fd, 859, 1492, 0, 0, usecper ); break;
	    case 'C': sst_tones( fd, 859, 1648, 0, 0, usecper ); break;
	    case '*': sst_tones( fd, 945, 1211, 0, 0, usecper ); break;
	    case '0': sst_tones( fd, 945, 1336, 0, 0, usecper ); break;
	    case '#': sst_tones( fd, 945, 1492, 0, 0, usecper ); break;
	    case 'D': sst_tones( fd, 945, 1648, 0, 0, usecper ); break;

	    case ' ': case '-': case '(': case ')': case '+':
	    continue;	/* ignore */

	    case ',': usleep( usecper ); break;	/* big pause */

	    default:
	      {
		Extbyte buf [255];
		sprintf( buf, "sst_dtmf: unknown dialing code '%c'", *cp );
		sound_warn (buf);
	      }
	    }
	usleep( usecpause );
	}
    }