[bpt/guile.git] / guile-readline / readline.c

/* readline.c --- line editing support for Guile */

/*	Copyright (C) 1997,1999, 2000 Free Software Foundation, Inc.
 * 
 * This program 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.
 * 
 * This program 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 this software; see the file COPYING.  If not, write to
 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
 * Boston, MA 02111-1307 USA
 *
 */

/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
   gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */

\f

#include "libguile/_scm.h"
#ifdef HAVE_RL_GETC_FUNCTION
#include "libguile.h"
#include "libguile/gh.h"
#include "libguile/iselect.h"

#include <readline/readline.h>
#include <readline/history.h>
#include <sys/time.h>

#include "libguile/validate.h"
#include "guile-readline/readline.h"

scm_option scm_readline_opts[] = {
  { SCM_OPTION_BOOLEAN, "history-file", 1,
    "Use history file." },
  { SCM_OPTION_INTEGER, "history-length", 200,
    "History length." },
  { SCM_OPTION_INTEGER, "bounce-parens", 500,
    "Time (ms) to show matching opening parenthesis (0 = off)."}
};

extern void stifle_history (int max);

SCM_DEFINE (scm_readline_options, "readline-options-interface", 0, 1, 0, 
            (SCM setting),
"")
#define FUNC_NAME s_scm_readline_options
{
  SCM ans = scm_options (setting,
			 scm_readline_opts,
			 SCM_N_READLINE_OPTIONS,
			 FUNC_NAME);
  stifle_history (SCM_HISTORY_LENGTH);
  return ans;
}
#undef FUNC_NAME

#ifndef HAVE_STRDUP
static char *
strdup (char *s)
{
  int len = strlen (s);
  char *new = malloc (len + 1);
  strcpy (new, s);
  return new;
}
#endif /* HAVE_STRDUP */

#ifndef HAVE_RL_CLEANUP_AFTER_SIGNAL

/* These are readline functions added in release 2.3.  They will work
 * together with readline-2.1 and 2.2.  (The readline interface is
 * disabled for earlier releases.)
 * They are declared static; if we want to use them elsewhere, then
 * we need external declarations for them, but at the moment, I don't
 * think anything else in Guile ought to use these.
 */

extern void _rl_clean_up_for_exit ();
extern void _rl_kill_kbd_macro ();
extern int _rl_init_argument ();

void
rl_cleanup_after_signal ()
{
#ifdef HAVE_RL_CLEAR_SIGNALS
  _rl_clean_up_for_exit ();
#endif
  (*rl_deprep_term_function) ();
#ifdef HAVE_RL_CLEAR_SIGNALS
  rl_clear_signals ();
#endif
  rl_pending_input = 0;
}

void
rl_free_line_state ()
{
  register HIST_ENTRY *entry;
   
  free_undo_list ();

  entry = current_history ();
  if (entry)
    entry->data = (char *)NULL; 
  
  _rl_kill_kbd_macro ();
  rl_clear_message ();
  _rl_init_argument ();
}

#endif /* !HAVE_RL_CLEANUP_AFTER_SIGNAL */

static int promptp;
static SCM input_port;
static SCM before_read;

static int
current_input_getc (FILE *in)
{
  if (promptp && SCM_NIMP (before_read))
    {
      scm_apply (before_read, SCM_EOL, SCM_EOL);
      promptp = 0;
    }
  return scm_getc (input_port);
}

static void
redisplay ()
{
  rl_redisplay ();
  /* promptp = 1; */
}

static int in_readline = 0;
#ifdef USE_THREADS
static scm_mutex_t reentry_barrier_mutex;
#endif

static SCM internal_readline (SCM text);
static SCM handle_error (void *data, SCM tag, SCM args);
static void reentry_barrier ();


SCM_DEFINE (scm_readline, "%readline", 0, 4, 0, 
            (SCM text, SCM inp, SCM outp, SCM read_hook),
"")
#define FUNC_NAME s_scm_readline
{
  SCM ans;
  
  reentry_barrier ();
  
  before_read = SCM_BOOL_F;

  if (!SCM_UNBNDP (text))
    {
      if (!(SCM_NIMP (text) && SCM_STRINGP (text)))
	{
	  --in_readline;
	  scm_wrong_type_arg (s_scm_readline, SCM_ARG1, text);
	}
      SCM_COERCE_SUBSTR (text);
    }
  
  if (!((SCM_UNBNDP (inp) && SCM_NIMP (scm_cur_inp) && SCM_OPINFPORTP (inp))
	|| SCM_NIMP (inp) && SCM_OPINFPORTP (inp)))
    {
      --in_readline;
      scm_misc_error (s_scm_readline,
		      "Input port is not open or not a file port",
		      SCM_EOL);
    }
  
  if (!((SCM_UNBNDP (outp) && SCM_NIMP (scm_cur_outp) && SCM_OPINFPORTP (outp))
	|| (SCM_NIMP (outp) && SCM_OPOUTFPORTP (outp))))
    {
      --in_readline;
      scm_misc_error (s_scm_readline,
		      "Output port is not open or not a file port",
		      SCM_EOL);
    }

  if (!(SCM_UNBNDP (read_hook) || SCM_FALSEP (read_hook)))
    {
      if (!(SCM_NFALSEP (scm_thunk_p (read_hook))))
	{
	  --in_readline;
	  scm_wrong_type_arg (s_scm_readline, SCM_ARG4, read_hook);
	}
      before_read = read_hook;
    }

  scm_readline_init_ports (inp, outp);

  ans = scm_internal_catch (SCM_BOOL_T,
			    (scm_catch_body_t) internal_readline,
			    (void *) SCM_UNPACK (text),
			    handle_error, 0);

  fclose (rl_instream);
  fclose (rl_outstream);

  --in_readline;
  return ans;
}
#undef FUNC_NAME


static void
reentry_barrier ()
{
  int reentryp = 0;
#ifdef USE_THREADS
  /* We should rather use scm_mutex_try_lock when it becomes available */
  scm_mutex_lock (&reentry_barrier_mutex);
#endif
  if (in_readline)
    reentryp = 1;
  else
    ++in_readline;
#ifdef USE_THREADS
  scm_mutex_unlock (&reentry_barrier_mutex);
#endif
  if (reentryp)
    scm_misc_error (s_scm_readline, "readline is not reentrant", SCM_EOL);
}

static SCM
handle_error (void *data, SCM tag, SCM args)
{
  rl_free_line_state ();
  rl_cleanup_after_signal ();
  fputc ('\n', rl_outstream); /* We don't want next output on this line */
  fclose (rl_instream);
  fclose (rl_outstream);
  --in_readline;
  scm_handle_by_throw (data, tag, args);
  return SCM_UNSPECIFIED; /* never reached */
}

static SCM
internal_readline (SCM text)
{
  SCM ret;
  char *s;
  char *prompt = SCM_UNBNDP (text) ? "" : SCM_CHARS (text);

  promptp = 1;
  s = readline (prompt);
  if (s)
    ret = scm_makfrom0str (s);
  else 
    ret = SCM_EOF_VAL;

  free (s);

  return ret;
}

static FILE *
stream_from_fport (SCM port, char *mode, const char *subr)
{
  int fd;
  FILE *f;

  fd = dup (((struct scm_fport *) SCM_STREAM (port))->fdes);
  if (fd == -1)
    {
      --in_readline;
      scm_syserror (subr);
    }

  f = fdopen (fd, mode);
  if (f == NULL)
    {
      --in_readline;
      scm_syserror (subr);
    }

  return f;
}

void
scm_readline_init_ports (SCM inp, SCM outp)
{
  if (SCM_UNBNDP (inp))
    inp = scm_cur_inp;
  
  if (SCM_UNBNDP (outp))
    outp = scm_cur_outp;
  
  if (!(SCM_NIMP (inp) && SCM_OPINFPORTP (inp))) {
    scm_misc_error (0,
                    "Input port is not open or not a file port",
                    SCM_EOL);
  }

  if (!(SCM_NIMP (outp) && SCM_OPOUTFPORTP (outp))) {
    scm_misc_error (0,
                    "Output port is not open or not a file port",
                    SCM_EOL);
  }

  input_port = inp;
  rl_instream = stream_from_fport (inp, "r", s_scm_readline);
  rl_outstream = stream_from_fport (outp, "w", s_scm_readline);
}


SCM_DEFINE (scm_add_history, "add-history", 1, 0, 0, 
            (SCM text),
"")
#define FUNC_NAME s_scm_add_history
{
  char* s;
  SCM_VALIDATE_STRING (1,text);
  SCM_COERCE_SUBSTR (text);

  s = SCM_CHARS (text);
  add_history (strdup (s));

  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME


SCM_DEFINE (scm_read_history, "read-history", 1, 0, 0, 
            (SCM file),
"")
#define FUNC_NAME s_scm_read_history
{
  SCM_VALIDATE_STRING (1,file);
  return SCM_NEGATE_BOOL(read_history (SCM_ROCHARS (file)));
}
#undef FUNC_NAME


SCM_DEFINE (scm_write_history, "write-history", 1, 0, 0, 
            (SCM file),
"")
#define FUNC_NAME s_scm_write_history
{
  SCM_VALIDATE_STRING (1,file);
  return SCM_NEGATE_BOOL(write_history (SCM_ROCHARS (file)));
}
#undef FUNC_NAME


SCM_DEFINE (scm_filename_completion_function, "filename-completion-function", 2, 0, 0, 
            (SCM text, SCM continuep),
"")
#define FUNC_NAME s_scm_filename_completion_function
{
  char *s;
  SCM ans;
  SCM_VALIDATE_STRING (1,text);
  SCM_COERCE_SUBSTR (text);
  s = filename_completion_function (SCM_CHARS (text), SCM_NFALSEP (continuep));
  ans = scm_makfrom0str (s);
  free (s);
  return ans;
}
#undef FUNC_NAME

/*
 * The following has been modified from code contributed by
 * Andrew Archibald <aarchiba@undergrad.math.uwaterloo.ca>
 */

SCM scm_readline_completion_function_var;

static char *
completion_function (char *text, int continuep)
{
  SCM compfunc = SCM_CDR (scm_readline_completion_function_var);
  SCM res;

  if (SCM_FALSEP (compfunc))
    return NULL; /* #f => completion disabled */
  else
    {
      SCM t = scm_makfrom0str (text);
      SCM c = continuep ? SCM_BOOL_T : SCM_BOOL_F;
      res = scm_apply (compfunc, SCM_LIST2 (t, c), SCM_EOL);
  
      if (SCM_FALSEP (res))
	return NULL;
  
      if (!(SCM_NIMP (res) && SCM_STRINGP (res)))
	scm_misc_error (s_scm_readline,
			"Completion function returned bogus value: %S",
			SCM_LIST1 (res));
      SCM_COERCE_SUBSTR (res);
      return strdup (SCM_CHARS (res));
    }
}

/*Bouncing parenthesis (reimplemented by GH, 11/23/98, since readline is strict gpl)*/

static int match_paren (int x, int k);
static int find_matching_paren (int k);
static void init_bouncing_parens ();

static void
init_bouncing_parens ()
{
  if (strncmp (rl_get_keymap_name (rl_get_keymap ()), "vi", 2))
    {
      rl_bind_key (')', match_paren);
      rl_bind_key (']', match_paren);
      rl_bind_key ('}', match_paren);
    }
}

static int
find_matching_paren(int k)
{
  register int i;
  register char c = 0;
  int end_parens_found = 0;

  /* Choose the corresponding opening bracket.  */
  if (k == ')') c = '(';
  else if (k == ']') c = '[';
  else if (k == '}') c = '{';

  for (i=rl_point-2; i>=0; i--)
    {
      /* Is the current character part of a character literal?  */
      if (i - 2 >= 0
	  && rl_line_buffer[i - 1] == '\\'
	  && rl_line_buffer[i - 2] == '#')
	;
      else if (rl_line_buffer[i] == k)
	end_parens_found++;
      else if (rl_line_buffer[i] == '"')
	{
	  /* Skip over a string literal.  */
	  for (i--; i >= 0; i--)
	    if (rl_line_buffer[i] == '"'
		&& ! (i - 1 >= 0
		      && rl_line_buffer[i - 1] == '\\'))
	      break;
	}
      else if (rl_line_buffer[i] == c)
	{
	  if (end_parens_found==0)
	    return i;
	  else --end_parens_found;
	}
    }
  return -1;
}

static int
match_paren (int x, int k)
{
  int tmp, fno;
  SELECT_TYPE readset;
  struct timeval timeout;
  
  rl_insert (x, k);
  if (!SCM_READLINE_BOUNCE_PARENS)
    return 0;

  /* Did we just insert a quoted paren?  If so, then don't bounce.  */
  if (rl_point - 1 >= 1
      && rl_line_buffer[rl_point - 2] == '\\')
    return 0;

  tmp = 1000 * SCM_READLINE_BOUNCE_PARENS;
  timeout.tv_sec = tmp / 1000000;
  timeout.tv_usec = tmp % 1000000;
  FD_ZERO (&readset);
  fno = fileno (rl_instream);
  FD_SET (fno, &readset);
  
  if (rl_point > 1)
    {
      tmp = rl_point;
      rl_point = find_matching_paren (k);
      if (rl_point > -1)
	{
	  rl_redisplay ();
	  scm_internal_select (fno + 1, &readset, NULL, NULL, &timeout);
	}
      rl_point = tmp;
    }
  return 0;
}

#endif /* HAVE_RL_GETC_FUNCTION */

void
scm_init_readline ()
{
#ifdef HAVE_RL_GETC_FUNCTION
#include "guile-readline/readline.x"
  scm_readline_completion_function_var
    = scm_sysintern ("*readline-completion-function*", SCM_BOOL_F);
  rl_getc_function = current_input_getc;
  rl_redisplay_function = redisplay;
  rl_completion_entry_function = (Function*) completion_function;
  rl_basic_word_break_characters = "\t\n\"'`;()";
  rl_readline_name = "Guile";

#ifdef USE_THREADS
  scm_mutex_init (&reentry_barrier_mutex);
#endif
  scm_init_opts (scm_readline_options,
		 scm_readline_opts,
		 SCM_N_READLINE_OPTIONS);
  init_bouncing_parens();
  scm_add_feature ("readline");
#endif /* HAVE_RL_GETC_FUNCTION */
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/
Commit	Line	Data
c374ab69 MV	1	/* readline.c --- line editing support for Guile */
c374ab69 MV	2
576cdec4	3	/* Copyright (C) 1997,1999, 2000 Free Software Foundation, Inc.
c374ab69 MV	4	*
	5	* This program is free software; you can redistribute it and/or modify
	6	* it under the terms of the GNU General Public License as published by
	7	* the Free Software Foundation; either version 2, or (at your option)
	8	* any later version.
	9	*
	10	* This program is distributed in the hope that it will be useful,
	11	* but WITHOUT ANY WARRANTY; without even the implied warranty of
	12	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	13	* GNU General Public License for more details.
	14	*
	15	* You should have received a copy of the GNU General Public License
	16	* along with this software; see the file COPYING. If not, write to
c6e23ea2 JB	17	* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
c6e23ea2 JB	18	* Boston, MA 02111-1307 USA
c374ab69 MV	19	*
c374ab69 MV	20	*/
f48e47b9 GB	21
	22	/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
	23	gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
	24
c374ab69 MV	25	\f
c374ab69 MV	26
739b3bf1	27	#include "libguile/_scm.h"
62947883	28	#ifdef HAVE_RL_GETC_FUNCTION
fbf68f8b	29	#include "libguile.h"
739b3bf1 MD	30	#include "libguile/gh.h"
	31	#include "libguile/iselect.h"
	32
c374ab69 MV	33	#include <readline/readline.h>
c374ab69 MV	34	#include <readline/history.h>
c374ab69	35	#include <sys/time.h>
c374ab69	36
1c537018	37	#include "libguile/validate.h"
a0599745	38	#include "guile-readline/readline.h"
c374ab69 MV	39
	40	scm_option scm_readline_opts[] = {
	41	{ SCM_OPTION_BOOLEAN, "history-file", 1,
	42	"Use history file." },
	43	{ SCM_OPTION_INTEGER, "history-length", 200,
	44	"History length." },
	45	{ SCM_OPTION_INTEGER, "bounce-parens", 500,
	46	"Time (ms) to show matching opening parenthesis (0 = off)."}
	47	};
	48
	49	extern void stifle_history (int max);
	50
b916d813	51	SCM_DEFINE (scm_readline_options, "readline-options-interface", 0, 1, 0,
f48e47b9 GB	52	(SCM setting),
	53	"")
	54	#define FUNC_NAME s_scm_readline_options
c374ab69 MV	55	{
	56	SCM ans = scm_options (setting,
	57	scm_readline_opts,
	58	SCM_N_READLINE_OPTIONS,
f48e47b9	59	FUNC_NAME);
c374ab69 MV	60	stifle_history (SCM_HISTORY_LENGTH);
	61	return ans;
	62	}
f48e47b9	63	#undef FUNC_NAME
c374ab69 MV	64
	65	#ifndef HAVE_STRDUP
	66	static char *
	67	strdup (char *s)
	68	{
	69	int len = strlen (s);
	70	char *new = malloc (len + 1);
	71	strcpy (new, s);
	72	return new;
	73	}
	74	#endif /* HAVE_STRDUP */
	75
	76	#ifndef HAVE_RL_CLEANUP_AFTER_SIGNAL
	77
	78	/* These are readline functions added in release 2.3. They will work
	79	* together with readline-2.1 and 2.2. (The readline interface is
	80	* disabled for earlier releases.)
	81	* They are declared static; if we want to use them elsewhere, then
	82	* we need external declarations for them, but at the moment, I don't
	83	* think anything else in Guile ought to use these.
	84	*/
	85
	86	extern void _rl_clean_up_for_exit ();
	87	extern void _rl_kill_kbd_macro ();
	88	extern int _rl_init_argument ();
	89
2e3d5987	90	void
c374ab69 MV	91	rl_cleanup_after_signal ()
	92	{
	93	#ifdef HAVE_RL_CLEAR_SIGNALS
	94	_rl_clean_up_for_exit ();
	95	#endif
	96	(*rl_deprep_term_function) ();
	97	#ifdef HAVE_RL_CLEAR_SIGNALS
	98	rl_clear_signals ();
	99	#endif
	100	rl_pending_input = 0;
	101	}
	102
2e3d5987	103	void
c374ab69 MV	104	rl_free_line_state ()
	105	{
	106	register HIST_ENTRY *entry;
	107
	108	free_undo_list ();
	109
	110	entry = current_history ();
	111	if (entry)
	112	entry->data = (char *)NULL;
	113
	114	_rl_kill_kbd_macro ();
	115	rl_clear_message ();
	116	_rl_init_argument ();
	117	}
	118
	119	#endif /* !HAVE_RL_CLEANUP_AFTER_SIGNAL */
	120
	121	static int promptp;
	122	static SCM input_port;
	123	static SCM before_read;
	124
	125	static int
	126	current_input_getc (FILE *in)
	127	{
c374ab69 MV	128	if (promptp && SCM_NIMP (before_read))
	129	{
	130	scm_apply (before_read, SCM_EOL, SCM_EOL);
	131	promptp = 0;
	132	}
bc858b80	133	return scm_getc (input_port);
c374ab69 MV	134	}
	135
	136	static void
	137	redisplay ()
	138	{
	139	rl_redisplay ();
	140	/* promptp = 1; */
	141	}
	142
c374ab69 MV	143	static int in_readline = 0;
	144	#ifdef USE_THREADS
	145	static scm_mutex_t reentry_barrier_mutex;
	146	#endif
	147
f48e47b9 GB	148	static SCM internal_readline (SCM text);
	149	static SCM handle_error (void *data, SCM tag, SCM args);
	150	static void reentry_barrier ();
	151
	152
b916d813	153	SCM_DEFINE (scm_readline, "%readline", 0, 4, 0,
f48e47b9 GB	154	(SCM text, SCM inp, SCM outp, SCM read_hook),
	155	"")
	156	#define FUNC_NAME s_scm_readline
	157	{
	158	SCM ans;
	159
	160	reentry_barrier ();
	161
	162	before_read = SCM_BOOL_F;
	163
	164	if (!SCM_UNBNDP (text))
	165	{
	166	if (!(SCM_NIMP (text) && SCM_STRINGP (text)))
	167	{
	168	--in_readline;
	169	scm_wrong_type_arg (s_scm_readline, SCM_ARG1, text);
	170	}
	171	SCM_COERCE_SUBSTR (text);
	172	}
	173
	174	if (!((SCM_UNBNDP (inp) && SCM_NIMP (scm_cur_inp) && SCM_OPINFPORTP (inp))
	175	\|\| SCM_NIMP (inp) && SCM_OPINFPORTP (inp)))
	176	{
	177	--in_readline;
	178	scm_misc_error (s_scm_readline,
	179	"Input port is not open or not a file port",
	180	SCM_EOL);
	181	}
	182
	183	if (!((SCM_UNBNDP (outp) && SCM_NIMP (scm_cur_outp) && SCM_OPINFPORTP (outp))
	184	\|\| (SCM_NIMP (outp) && SCM_OPOUTFPORTP (outp))))
	185	{
	186	--in_readline;
	187	scm_misc_error (s_scm_readline,
	188	"Output port is not open or not a file port",
	189	SCM_EOL);
	190	}
	191
	192	if (!(SCM_UNBNDP (read_hook) \|\| SCM_FALSEP (read_hook)))
	193	{
	194	if (!(SCM_NFALSEP (scm_thunk_p (read_hook))))
	195	{
	196	--in_readline;
	197	scm_wrong_type_arg (s_scm_readline, SCM_ARG4, read_hook);
	198	}
	199	before_read = read_hook;
	200	}
	201
	202	scm_readline_init_ports (inp, outp);
	203
	204	ans = scm_internal_catch (SCM_BOOL_T,
	205	(scm_catch_body_t) internal_readline,
f60d011a	206	(void *) SCM_UNPACK (text),
f48e47b9 GB	207	handle_error, 0);
	208
	209	fclose (rl_instream);
	210	fclose (rl_outstream);
	211
	212	--in_readline;
	213	return ans;
	214	}
	215	#undef FUNC_NAME
	216
	217
c374ab69 MV	218	static void
	219	reentry_barrier ()
	220	{
	221	int reentryp = 0;
	222	#ifdef USE_THREADS
	223	/* We should rather use scm_mutex_try_lock when it becomes available */
	224	scm_mutex_lock (&reentry_barrier_mutex);
	225	#endif
	226	if (in_readline)
	227	reentryp = 1;
	228	else
	229	++in_readline;
	230	#ifdef USE_THREADS
	231	scm_mutex_unlock (&reentry_barrier_mutex);
	232	#endif
	233	if (reentryp)
f48e47b9	234	scm_misc_error (s_scm_readline, "readline is not reentrant", SCM_EOL);
c374ab69 MV	235	}
	236
	237	static SCM
	238	handle_error (void *data, SCM tag, SCM args)
	239	{
	240	rl_free_line_state ();
	241	rl_cleanup_after_signal ();
739b3bf1	242	fputc ('\n', rl_outstream); /* We don't want next output on this line */
c374ab69 MV	243	fclose (rl_instream);
	244	fclose (rl_outstream);
	245	--in_readline;
	246	scm_handle_by_throw (data, tag, args);
	247	return SCM_UNSPECIFIED; /* never reached */
	248	}
	249
	250	static SCM
	251	internal_readline (SCM text)
	252	{
	253	SCM ret;
	254	char *s;
	255	char *prompt = SCM_UNBNDP (text) ? "" : SCM_CHARS (text);
	256
	257	promptp = 1;
	258	s = readline (prompt);
	259	if (s)
	260	ret = scm_makfrom0str (s);
	261	else
	262	ret = SCM_EOF_VAL;
	263
	264	free (s);
	265
	266	return ret;
	267	}
	268
	269	static FILE *
	270	stream_from_fport (SCM port, char mode, const char subr)
	271	{
	272	int fd;
	273	FILE *f;
	274
	275	fd = dup (((struct scm_fport *) SCM_STREAM (port))->fdes);
	276	if (fd == -1)
	277	{
	278	--in_readline;
	279	scm_syserror (subr);
	280	}
	281
	282	f = fdopen (fd, mode);
	283	if (f == NULL)
	284	{
	285	--in_readline;
	286	scm_syserror (subr);
	287	}
	288
	289	return f;
	290	}
	291
2e3d5987 MD	292	void
	293	scm_readline_init_ports (SCM inp, SCM outp)
	294	{
	295	if (SCM_UNBNDP (inp))
	296	inp = scm_cur_inp;
	297
	298	if (SCM_UNBNDP (outp))
	299	outp = scm_cur_outp;
	300
	301	if (!(SCM_NIMP (inp) && SCM_OPINFPORTP (inp))) {
	302	scm_misc_error (0,
	303	"Input port is not open or not a file port",
	304	SCM_EOL);
	305	}
	306
	307	if (!(SCM_NIMP (outp) && SCM_OPOUTFPORTP (outp))) {
	308	scm_misc_error (0,
	309	"Output port is not open or not a file port",
	310	SCM_EOL);
	311	}
	312
	313	input_port = inp;
f48e47b9 GB	314	rl_instream = stream_from_fport (inp, "r", s_scm_readline);
f48e47b9 GB	315	rl_outstream = stream_from_fport (outp, "w", s_scm_readline);
2e3d5987 MD	316	}
2e3d5987 MD	317
c374ab69	318
c374ab69	319
b916d813	320	SCM_DEFINE (scm_add_history, "add-history", 1, 0, 0,
f48e47b9 GB	321	(SCM text),
	322	"")
	323	#define FUNC_NAME s_scm_add_history
c374ab69 MV	324	{
c374ab69 MV	325	char* s;
cbaee92a	326	SCM_VALIDATE_STRING (1,text);
c374ab69 MV	327	SCM_COERCE_SUBSTR (text);
	328
	329	s = SCM_CHARS (text);
	330	add_history (strdup (s));
	331
	332	return SCM_UNSPECIFIED;
	333	}
f48e47b9	334	#undef FUNC_NAME
c374ab69 MV	335
c374ab69 MV	336
b916d813	337	SCM_DEFINE (scm_read_history, "read-history", 1, 0, 0,
f48e47b9 GB	338	(SCM file),
	339	"")
	340	#define FUNC_NAME s_scm_read_history
c374ab69	341	{
cbaee92a	342	SCM_VALIDATE_STRING (1,file);
f48e47b9	343	return SCM_NEGATE_BOOL(read_history (SCM_ROCHARS (file)));
c374ab69	344	}
f48e47b9	345	#undef FUNC_NAME
c374ab69 MV	346
c374ab69 MV	347
b916d813	348	SCM_DEFINE (scm_write_history, "write-history", 1, 0, 0,
f48e47b9 GB	349	(SCM file),
	350	"")
	351	#define FUNC_NAME s_scm_write_history
c374ab69	352	{
cbaee92a	353	SCM_VALIDATE_STRING (1,file);
f48e47b9	354	return SCM_NEGATE_BOOL(write_history (SCM_ROCHARS (file)));
c374ab69	355	}
f48e47b9	356	#undef FUNC_NAME
c374ab69 MV	357
c374ab69 MV	358
b916d813	359	SCM_DEFINE (scm_filename_completion_function, "filename-completion-function", 2, 0, 0,
f48e47b9 GB	360	(SCM text, SCM continuep),
	361	"")
	362	#define FUNC_NAME s_scm_filename_completion_function
c374ab69 MV	363	{
	364	char *s;
	365	SCM ans;
cbaee92a	366	SCM_VALIDATE_STRING (1,text);
c374ab69 MV	367	SCM_COERCE_SUBSTR (text);
	368	s = filename_completion_function (SCM_CHARS (text), SCM_NFALSEP (continuep));
	369	ans = scm_makfrom0str (s);
	370	free (s);
	371	return ans;
	372	}
f48e47b9	373	#undef FUNC_NAME
c374ab69 MV	374
	375	/*
	376	* The following has been modified from code contributed by
	377	* Andrew Archibald <aarchiba@undergrad.math.uwaterloo.ca>
	378	*/
	379
	380	SCM scm_readline_completion_function_var;
	381
	382	static char *
	383	completion_function (char *text, int continuep)
	384	{
	385	SCM compfunc = SCM_CDR (scm_readline_completion_function_var);
	386	SCM res;
	387
	388	if (SCM_FALSEP (compfunc))
	389	return NULL; /* #f => completion disabled */
	390	else
	391	{
	392	SCM t = scm_makfrom0str (text);
	393	SCM c = continuep ? SCM_BOOL_T : SCM_BOOL_F;
	394	res = scm_apply (compfunc, SCM_LIST2 (t, c), SCM_EOL);
	395
	396	if (SCM_FALSEP (res))
	397	return NULL;
	398
	399	if (!(SCM_NIMP (res) && SCM_STRINGP (res)))
f48e47b9	400	scm_misc_error (s_scm_readline,
c374ab69 MV	401	"Completion function returned bogus value: %S",
	402	SCM_LIST1 (res));
	403	SCM_COERCE_SUBSTR (res);
	404	return strdup (SCM_CHARS (res));
	405	}
	406	}
	407
	408	/Bouncing parenthesis (reimplemented by GH, 11/23/98, since readline is strict gpl)/
	409
576cdec4 MD	410	static int match_paren (int x, int k);
	411	static int find_matching_paren (int k);
	412	static void init_bouncing_parens ();
c374ab69 MV	413
c374ab69 MV	414	static void
576cdec4	415	init_bouncing_parens ()
c374ab69	416	{
576cdec4 MD	417	if (strncmp (rl_get_keymap_name (rl_get_keymap ()), "vi", 2))
	418	{
	419	rl_bind_key (')', match_paren);
	420	rl_bind_key (']', match_paren);
	421	rl_bind_key ('}', match_paren);
	422	}
c374ab69 MV	423	}
	424
	425	static int
	426	find_matching_paren(int k)
	427	{
	428	register int i;
	429	register char c = 0;
	430	int end_parens_found = 0;
	431
	432	/* Choose the corresponding opening bracket. */
	433	if (k == ')') c = '(';
	434	else if (k == ']') c = '[';
	435	else if (k == '}') c = '{';
	436
	437	for (i=rl_point-2; i>=0; i--)
	438	{
	439	/* Is the current character part of a character literal? */
	440	if (i - 2 >= 0
	441	&& rl_line_buffer[i - 1] == '\\'
	442	&& rl_line_buffer[i - 2] == '#')
	443	;
	444	else if (rl_line_buffer[i] == k)
	445	end_parens_found++;
	446	else if (rl_line_buffer[i] == '"')
	447	{
	448	/* Skip over a string literal. */
	449	for (i--; i >= 0; i--)
	450	if (rl_line_buffer[i] == '"'
	451	&& ! (i - 1 >= 0
	452	&& rl_line_buffer[i - 1] == '\\'))
	453	break;
	454	}
	455	else if (rl_line_buffer[i] == c)
	456	{
576cdec4 MD	457	if (end_parens_found==0)
576cdec4 MD	458	return i;
c374ab69 MV	459	else --end_parens_found;
	460	}
	461	}
	462	return -1;
	463	}
	464
576cdec4 MD	465	static int
576cdec4 MD	466	match_paren (int x, int k)
c374ab69	467	{
bc858b80	468	int tmp, fno;
aba2031a	469	SELECT_TYPE readset;
c374ab69 MV	470	struct timeval timeout;
c374ab69 MV	471
576cdec4	472	rl_insert (x, k);
c374ab69	473	if (!SCM_READLINE_BOUNCE_PARENS)
576cdec4	474	return 0;
c374ab69 MV	475
	476	/* Did we just insert a quoted paren? If so, then don't bounce. */
	477	if (rl_point - 1 >= 1
	478	&& rl_line_buffer[rl_point - 2] == '\\')
576cdec4	479	return 0;
c374ab69 MV	480
	481	tmp = 1000 * SCM_READLINE_BOUNCE_PARENS;
	482	timeout.tv_sec = tmp / 1000000;
	483	timeout.tv_usec = tmp % 1000000;
576cdec4	484	FD_ZERO (&readset);
bc858b80 MD	485	fno = fileno (rl_instream);
bc858b80 MD	486	FD_SET (fno, &readset);
c374ab69	487
576cdec4 MD	488	if (rl_point > 1)
	489	{
	490	tmp = rl_point;
	491	rl_point = find_matching_paren (k);
	492	if (rl_point > -1)
	493	{
	494	rl_redisplay ();
bc858b80	495	scm_internal_select (fno + 1, &readset, NULL, NULL, &timeout);
576cdec4 MD	496	}
576cdec4 MD	497	rl_point = tmp;
c374ab69	498	}
576cdec4	499	return 0;
c374ab69 MV	500	}
c374ab69 MV	501
62947883	502	#endif /* HAVE_RL_GETC_FUNCTION */
c374ab69 MV	503
	504	void
	505	scm_init_readline ()
	506	{
62947883	507	#ifdef HAVE_RL_GETC_FUNCTION
a0599745	508	#include "guile-readline/readline.x"
c374ab69 MV	509	scm_readline_completion_function_var
	510	= scm_sysintern ("readline-completion-function", SCM_BOOL_F);
	511	rl_getc_function = current_input_getc;
	512	rl_redisplay_function = redisplay;
	513	rl_completion_entry_function = (Function*) completion_function;
	514	rl_basic_word_break_characters = "\t\n\"'`;()";
5c11cc9d GH	515	rl_readline_name = "Guile";
5c11cc9d GH	516
c374ab69	517	#ifdef USE_THREADS
b74b1a63	518	scm_mutex_init (&reentry_barrier_mutex);
c374ab69 MV	519	#endif
	520	scm_init_opts (scm_readline_options,
	521	scm_readline_opts,
	522	SCM_N_READLINE_OPTIONS);
	523	init_bouncing_parens();
	524	scm_add_feature ("readline");
62947883	525	#endif /* HAVE_RL_GETC_FUNCTION */
c374ab69 MV	526	}
c374ab69 MV	527
89e00824 ML	528	/*
	529	Local Variables:
	530	c-file-style: "gnu"
	531	End:
	532	*/