[bpt/guile.git] / libguile / print.c

/*	Copyright (C) 1995,1996 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, 675 Mass Ave, Cambridge, MA 02139, USA.
 *
 * As a special exception, the Free Software Foundation gives permission
 * for additional uses of the text contained in its release of GUILE.
 *
 * The exception is that, if you link the GUILE library with other files
 * to produce an executable, this does not by itself cause the
 * resulting executable to be covered by the GNU General Public License.
 * Your use of that executable is in no way restricted on account of
 * linking the GUILE library code into it.
 *
 * This exception does not however invalidate any other reasons why
 * the executable file might be covered by the GNU General Public License.
 *
 * This exception applies only to the code released by the
 * Free Software Foundation under the name GUILE.  If you copy
 * code from other Free Software Foundation releases into a copy of
 * GUILE, as the General Public License permits, the exception does
 * not apply to the code that you add in this way.  To avoid misleading
 * anyone as to the status of such modified files, you must delete
 * this exception notice from them.
 *
 * If you write modifications of your own for GUILE, it is your choice
 * whether to permit this exception to apply to your modifications.
 * If you do not wish that, delete this exception notice.  
 */
\f

#include <stdio.h>
#include "_scm.h"
#include "chars.h"
#include "genio.h"
#include "mbstrings.h"
#include "smob.h"
#include "eval.h"
#include "procprop.h"
#include "read.h"
#include "weaks.h"
#include "unif.h"

#include "print.h"
\f

/* {Names of immediate symbols}
 * 
 * This table must agree with the declarations in scm.h: {Immediate Symbols}.
 */

char *scm_isymnames[] =
{
  /* This table must agree with the declarations */
  "#@and",
  "#@begin",
  "#@case",
  "#@cond",
  "#@do",
  "#@if",
  "#@lambda",
  "#@let",
  "#@let*",
  "#@letrec",
  "#@or",
  "#@quote",
  "#@set!",
  "#@define",
#if 0
  "#@literal-variable-ref",
  "#@literal-variable-set!",
#endif
  "#@apply",
  "#@call-with-current-continuation",

 /* user visible ISYMS */
 /* other keywords */
 /* Flags */

  "#f",
  "#t",
  "#<undefined>",
  "#<eof>",
  "()",
  "#<unspecified>"
};

#ifdef DEBUG_EXTENSIONS
scm_option scm_print_opts[] = {
  { SCM_OPTION_BOOLEAN, "procnames", 0,
    "Print names instead of closures." },
  { SCM_OPTION_SCM, "closure-hook", SCM_BOOL_F,
    "Procedure used to print closures." }
};

SCM_PROC (s_print_options, "print-options-interface", 0, 1, 0, scm_print_options);
#ifdef __STDC__
SCM
scm_print_options (SCM setting)
#else
SCM
scm_print_options (setting)
     SCM setting;
#endif
{
  SCM ans = scm_options (setting,
			 scm_print_opts,
			 SCM_N_PRINT_OPTIONS,
			 s_print_options);
  return ans;
}
#endif

\f
/* {Printing of Scheme Objects}
 */

/* Detection of circular references.
 */
typedef struct ref_stack {
  SCM vector;
  SCM *top;
  SCM *ceiling;
  SCM *floor;
} ref_stack;

#define RESET_REF_STACK(stack) { stack.top = stack.floor; }
#define PUSH_REF(stack, obj, label) \
{ \
  register SCM *ref; \
  for (ref = stack.floor; ref < stack.top; ++ref) \
    if (*ref == (obj)) \
      goto label; \
  *stack.top++ = (obj); \
  if (stack.top == stack.ceiling) \
    grow_ref_stack (&stack); \
} \

#define POP_REF(stack) { --stack.top; }
#define SAVE_REF_STACK(stack, save) \
{ \
  save = stack.floor - SCM_VELTS (stack.vector); \
  stack.floor = stack.top; \
} \

#define RESTORE_REF_STACK(stack, save) \
{ stack.floor = SCM_VELTS (stack.vector) + save; }

#ifdef __STDC__
static void
init_ref_stack (ref_stack *stack)
#else
static void
init_ref_stack (stack)
     ref_stack *stack;
#endif
{
  stack->vector = scm_permanent_object (scm_make_vector (SCM_MAKINUM (30L),
							 SCM_UNDEFINED,
							 SCM_UNDEFINED));
  stack->top = stack->floor = SCM_VELTS (stack->vector);
  stack->ceiling = stack->floor + SCM_LENGTH (stack->vector);
}

#ifdef __STDC__
static void
grow_ref_stack (ref_stack *stack)
#else
static void
grow_ref_stack (stack)
     ref_stack *stack;
#endif
{
  int offset, new_size = 2 * SCM_LENGTH (stack->vector);
  SCM *old_velts = SCM_VELTS (stack->vector);
  scm_vector_set_length_x (stack->vector, SCM_MAKINUM (new_size));
  offset = SCM_VELTS (stack->vector) - old_velts;
  stack->top += offset;
  stack->floor += offset;
  stack->ceiling = SCM_VELTS (stack->vector) + new_size;
}


/* Print generally.  Handles both write and display according to WRITING.
 */

static ref_stack pstack;

#ifdef __STDC__
void 
scm_iprin1 (SCM exp, SCM port, int writing)
#else
void 
scm_iprin1 (exp, port, writing)
     SCM exp;
     SCM port;
     int writing;
#endif
{
  register long i;
taloop:
  switch (7 & (int) exp)
    {
    case 2:
    case 6:
      scm_intprint (SCM_INUM (exp), 10, port);
      break;
    case 4:
      if (SCM_ICHRP (exp))
	{
	  i = SCM_ICHR (exp);
	  scm_put_wchar (i, port, writing);

	}
      else if (SCM_IFLAGP (exp)
	       && (SCM_ISYMNUM (exp) < (sizeof scm_isymnames / sizeof (char *))))
	  scm_gen_puts (scm_regular_string, SCM_ISYMSCM_CHARS (exp), port);
      else if (SCM_ILOCP (exp))
	{
	  scm_gen_puts (scm_regular_string, "#@", port);
	  scm_intprint ((long) SCM_IFRAME (exp), 10, port);
	  scm_gen_putc (SCM_ICDRP (exp) ? '-' : '+', port);
	  scm_intprint ((long) SCM_IDIST (exp), 10, port);
	}
      else
	goto idef;
      break;
    case 1:
      /* gloc */
      scm_gen_puts (scm_regular_string, "#@", port);
      exp = SCM_CAR (exp - 1);
      goto taloop;
    default:
    idef:
      scm_ipruk ("immediate", exp, port);
      break;
    case 0:
      switch (SCM_TYP7 (exp))
	{
	case scm_tcs_cons_gloc:

	  if (SCM_CDR (SCM_CAR (exp) - 1L) == 0)
	    {
	      scm_gen_write (scm_regular_string, "#<struct ", sizeof ("#<struct ") - 1, port);
	      scm_intprint(exp, 16, port);
	      scm_gen_putc ('>', port);
	      break;
	    }

	case scm_tcs_cons_imcar:
	case scm_tcs_cons_nimcar:
	  PUSH_REF (pstack, exp, circref);
	  scm_iprlist ("(", exp, ')', port, writing);
	  POP_REF (pstack);
	  break;
	circref:
	  scm_gen_write (scm_regular_string, "#<circ ref>", sizeof ("#<circ ref>") - 1, port);
	  break;
	case scm_tcs_closures:
#ifdef DEBUG_EXTENSIONS
	  if (SCM_NFALSEP (scm_procedure_p (SCM_PRINT_CLOSURE)))
	    {
	      SCM ans = scm_cons2 (exp, port,
				   scm_cons (writing ? SCM_BOOL_T : SCM_BOOL_F, SCM_EOL));
	      int save;
	      SAVE_REF_STACK (pstack, save);
	      ans = scm_apply (SCM_PRINT_CLOSURE, ans, SCM_EOL);
	      RESTORE_REF_STACK (pstack, save);
	    }
	  else if (SCM_PRINT_PROCNAMES_P)
	    {
	      SCM name;
	      name = scm_procedure_property (exp, scm_i_name);
	      scm_gen_puts (scm_regular_string, "#<procedure", port);
	      if (SCM_NFALSEP (name))
		{
		  scm_gen_putc (' ', port);
		  /* FIXME */
		  scm_gen_puts (scm_regular_string, SCM_CHARS (name), port);
		}
	      scm_gen_putc ('>', port);
	    }
	  else
#endif
	    {
	      SCM code = SCM_CODE (exp);
	      exp = scm_unmemocopy (code,
				    SCM_EXTEND_SCM_ENV (SCM_CAR (code),
							SCM_EOL,
							SCM_ENV (exp)));
	      scm_iprlist ("#<CLOSURE ", exp, '>', port, writing);
	    }
	  break;
	case scm_tc7_mb_string:
	case scm_tc7_mb_substring:
	  scm_print_mb_string (exp, port, writing);
	  break;
	case scm_tc7_substring:
	case scm_tc7_string:
	  if (writing)
	    {
	      scm_gen_putc ('\"', port);
	      for (i = 0; i < SCM_ROLENGTH (exp); ++i)
		switch (SCM_ROCHARS (exp)[i])
		  {
		  case '\"':
		  case '\\':
		    scm_gen_putc ('\\', port);
		  default:
		    scm_gen_putc (SCM_ROCHARS (exp)[i], port);
		  }
	      scm_gen_putc ('\"', port);
	      break;
	    }
	  else
	    scm_gen_write (scm_regular_string, SCM_ROCHARS (exp),
			   (scm_sizet) SCM_ROLENGTH (exp),
			   port);
	  break;
	case scm_tcs_symbols:
	  if (SCM_MB_STRINGP (exp))
	    {
	      scm_print_mb_symbol (exp, port);
	      break;
	    }
	  else
	    {
	      int pos;
	      int end;
	      int len;
	      char * str;
	      int weird;
	      int maybe_weird;
	      int mw_pos;

	      len = SCM_LENGTH (exp);
	      str = SCM_CHARS (exp);
	      scm_remember (&exp);
	      pos = 0;
	      weird = 0;
	      maybe_weird = 0;

	      if (len == 0)
		scm_gen_write (scm_regular_string, "#{}#", 4, port);

	      for (end = pos; end < len; ++end)
		switch (str[end])
		  {
#ifdef BRACKETS_AS_PARENS
		  case '[':
		  case ']':
#endif
		  case '(':
		  case ')':
		  case '\"':
		  case ';':
		  case SCM_WHITE_SPACES:
		  case SCM_LINE_INCREMENTORS:
		  weird_handler:
		    if (maybe_weird)
		      {
			end = mw_pos;
			maybe_weird = 0;
		      }
		    if (!weird)
		      {
			scm_gen_write (scm_regular_string, "#{", 2, port);
			weird = 1;
		      }
		    if (pos < end)
		      {
			scm_gen_write (scm_regular_string, str + pos, end - pos, port);
		      }
		    {
		      char buf[2];
		      buf[0] = '\\';
		      buf[1] = str[end];
		      scm_gen_write (scm_regular_string, buf, 2, port);
		    }
		    pos = end + 1;
		    break;
		  case '\\':
		    if (weird)
		      goto weird_handler;
		    if (!maybe_weird)
		      {
			maybe_weird = 1;
			mw_pos = pos;
		      }
		    break;
		  case '}':
		  case '#':
		    if (weird)
		      goto weird_handler;
		    break;
		  default:
		    break;
		  }
	      if (pos < end)
		scm_gen_write (scm_regular_string, str + pos, end - pos, port);
	      if (weird)
		scm_gen_write (scm_regular_string, "}#", 2, port);
	      break;
	    }
	case scm_tc7_wvect:
	  PUSH_REF (pstack, exp, circref);
	  if (SCM_IS_WHVEC (exp))
	    scm_gen_puts (scm_regular_string, "#wh(", port);
	  else
	    scm_gen_puts (scm_regular_string, "#w(", port);
	  goto common_vector_printer;

	case scm_tc7_vector:
	  PUSH_REF (pstack, exp, circref);
	  scm_gen_puts (scm_regular_string, "#(", port);
	common_vector_printer:
	  for (i = 0; i + 1 < SCM_LENGTH (exp); ++i)
	    {
	      /* CHECK_INTS; */
	      scm_iprin1 (SCM_VELTS (exp)[i], port, writing);
	      scm_gen_putc (' ', port);
	    }
	  if (i < SCM_LENGTH (exp))
	    {
	      /* CHECK_INTS; */
	      scm_iprin1 (SCM_VELTS (exp)[i], port, writing);
	    }
	  scm_gen_putc (')', port);
	  POP_REF (pstack);
	  break;
	case scm_tc7_bvect:
	case scm_tc7_byvect:
	case scm_tc7_svect:
	case scm_tc7_ivect:
	case scm_tc7_uvect:
	case scm_tc7_fvect:
	case scm_tc7_dvect:
	case scm_tc7_cvect:
#ifdef LONGLONGS
	case scm_tc7_llvect:
#endif
	  scm_raprin1 (exp, port, writing);
	  break;
	case scm_tcs_subrs:
	  scm_gen_puts (scm_regular_string, "#<primitive-procedure ", port);
	  scm_gen_puts ((SCM_MB_STRINGP (SCM_SNAME(exp))
			 ? scm_mb_string
			 : scm_regular_string),
			SCM_CHARS (SCM_SNAME (exp)), port);
	  scm_gen_putc ('>', port);
	  break;
#ifdef CCLO
	case scm_tc7_cclo:
	  scm_gen_puts (scm_regular_string, "#<compiled-closure ", port);
	  scm_iprin1 (SCM_CCLO_SUBR (exp), port, writing);
	  scm_gen_putc ('>', port);
	  break;
#endif
	case scm_tc7_contin:
	  scm_gen_puts (scm_regular_string, "#<continuation ", port);
	  scm_intprint (SCM_LENGTH (exp), 10, port);
	  scm_gen_puts (scm_regular_string, " @ ", port);
	  scm_intprint ((long) SCM_CHARS (exp), 16, port);
	  scm_gen_putc ('>', port);
	  break;
	case scm_tc7_port:
	  i = SCM_PTOBNUM (exp);
	  if (i < scm_numptob && scm_ptobs[i].print && (scm_ptobs[i].print) (exp, port, writing))
	    break;
	  goto punk;
	case scm_tc7_smob:
	  PUSH_REF (pstack, exp, circref);
	  i = SCM_SMOBNUM (exp);
	  if (i < scm_numsmob && scm_smobs[i].print
	      && (scm_smobs[i].print) (exp, port, writing))
	    {
	      POP_REF (pstack);
	      break;
	    }
	  POP_REF (pstack);
	default:
	punk:
	  scm_ipruk ("type", exp, port);
	}
    }
}

#ifdef __STDC__
void 
scm_prin1 (SCM exp, SCM port, int writing)
#else
void 
scm_prin1 (exp, port, writing)
     SCM exp;
     SCM port;
     int writing;
#endif
{
  RESET_REF_STACK (pstack);
  scm_iprin1 (exp, port, writing);
}


/* Print an integer.
 */
#ifdef __STDC__
void 
scm_intprint (long n, int radix, SCM port)
#else
void 
scm_intprint (n, radix, port)
     long n;
     int radix;
     SCM port;
#endif
{
  char num_buf[SCM_INTBUFLEN];
  scm_gen_write (scm_regular_string, num_buf, scm_iint2str (n, radix, num_buf), port);
}

/* Print an object of unrecognized type.
 */
#ifdef __STDC__
void 
scm_ipruk (char *hdr, SCM ptr, SCM port)
#else
void 
scm_ipruk (hdr, ptr, port)
     char *hdr;
     SCM ptr;
     SCM port;
#endif
{
  scm_gen_puts (scm_regular_string, "#<unknown-", port);
  scm_gen_puts (scm_regular_string, hdr, port);
  if (SCM_CELLP (ptr))
    {
      scm_gen_puts (scm_regular_string, " (0x", port);
      scm_intprint (SCM_CAR (ptr), 16, port);
      scm_gen_puts (scm_regular_string, " . 0x", port);
      scm_intprint (SCM_CDR (ptr), 16, port);
      scm_gen_puts (scm_regular_string, ") @", port);
    }
  scm_gen_puts (scm_regular_string, " 0x", port);
  scm_intprint (ptr, 16, port);
  scm_gen_putc ('>', port);
}

/* Print a list.
 */

static ref_stack lstack;

#ifdef __STDC__
void 
scm_iprlist (char *hdr, SCM exp, char tlr, SCM port, int writing)
#else
void 
scm_iprlist (hdr, exp, tlr, port, writing)
     char *hdr;
     SCM exp;
     char tlr;
     SCM port;
     int writing;
#endif
{
  scm_gen_puts (scm_regular_string, hdr, port);
  /* CHECK_INTS; */
  scm_iprin1 (SCM_CAR (exp), port, writing);
  RESET_REF_STACK (lstack);
  PUSH_REF (lstack, exp, circref);
  exp = SCM_CDR (exp);
  for (; SCM_NIMP (exp); exp = SCM_CDR (exp))
    {
      if (SCM_NECONSP (exp))
	break;
      PUSH_REF (lstack, exp, circref);
      scm_gen_putc (' ', port);
      /* CHECK_INTS; */
      scm_iprin1 (SCM_CAR (exp), port, writing);
    }
  if (SCM_NNULLP (exp))
    {
      scm_gen_puts (scm_regular_string, " . ", port);
      scm_iprin1 (exp, port, writing);
    }
end:
  scm_gen_putc (tlr, port);
  return;
circref:
  scm_gen_puts (scm_regular_string, " . #<circ ref>", port);
  goto end;
}

#ifdef __STDC__
void 
scm_prlist (char *hdr, SCM exp, char tlr, SCM port, int writing)
#else
void 
scm_prlist (hdr, exp, tlr, port, writing)
     char *hdr;
     SCM exp;
     char tlr;
     SCM port;
     int writing;
#endif
{
  RESET_REF_STACK (pstack);
  scm_iprlist (hdr, exp, tlr, port, writing);
}

\f

SCM_PROC(s_write, "write", 1, 1, 0, scm_write);
#ifdef __STDC__
SCM 
scm_write (SCM obj, SCM port)
#else
SCM 
scm_write (obj, port)
     SCM obj;
     SCM port;
#endif
{
  if (SCM_UNBNDP (port))
    port = scm_cur_outp;
  else
    SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write);
  scm_prin1 (obj, port, 1);
#ifdef HAVE_PIPE
# ifdef EPIPE
  if (EPIPE == errno)
    scm_close_port (port);
# endif
#endif
  return SCM_UNSPECIFIED;
}


SCM_PROC(s_display, "display", 1, 1, 0, scm_display);
#ifdef __STDC__
SCM 
scm_display (SCM obj, SCM port)
#else
SCM 
scm_display (obj, port)
     SCM obj;
     SCM port;
#endif
{
  if (SCM_UNBNDP (port))
    port = scm_cur_outp;
  else
    SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_display);
  scm_prin1 (obj, port, 0);
#ifdef HAVE_PIPE
# ifdef EPIPE
  if (EPIPE == errno)
    scm_close_port (port);
# endif
#endif
  return SCM_UNSPECIFIED;
}

SCM_PROC(s_newline, "newline", 0, 1, 0, scm_newline);
#ifdef __STDC__
SCM
scm_newline(SCM port)
#else
SCM 
scm_newline (port)
     SCM port;
#endif
{
  if (SCM_UNBNDP (port))
 port = scm_cur_outp;
  else
    SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_newline);
  scm_gen_putc ('\n', port);
#ifdef HAVE_PIPE
# ifdef EPIPE
  if (EPIPE == errno)
    scm_close_port (port);
  else
# endif
#endif
  if (port == scm_cur_outp)
    scm_fflush (port);
  return SCM_UNSPECIFIED;
}

SCM_PROC(s_write_char, "write-char", 1, 1, 0, scm_write_char);
#ifdef __STDC__
SCM 
scm_write_char (SCM chr, SCM port)
#else
SCM 
scm_write_char (chr, port)
     SCM chr;
     SCM port;
#endif
{
  if (SCM_UNBNDP (port))
 port = scm_cur_outp;
  else
    SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write_char);
  SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG1, s_write_char);
  scm_gen_putc ((int) SCM_ICHR (chr), port);
#ifdef HAVE_PIPE
# ifdef EPIPE
  if (EPIPE == errno)
    scm_close_port (port);
# endif
#endif
  return SCM_UNSPECIFIED;
}


\f

#ifdef __STDC__
void
scm_init_print (void)
#else
void
scm_init_print ()
#endif
{
#ifdef DEBUG_EXTENSIONS
  scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS);
  init_ref_stack (&pstack);
  init_ref_stack (&lstack);
#endif
#include "print.x"
}
Commit	Line	Data
0f2d19dd JB	1	/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
	2	*
	3	* This program is free software; you can redistribute it and/or modify
	4	* it under the terms of the GNU General Public License as published by
	5	* the Free Software Foundation; either version 2, or (at your option)
	6	* any later version.
	7	*
	8	* This program is distributed in the hope that it will be useful,
	9	* but WITHOUT ANY WARRANTY; without even the implied warranty of
	10	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	11	* GNU General Public License for more details.
	12	*
	13	* You should have received a copy of the GNU General Public License
	14	* along with this software; see the file COPYING. If not, write to
	15	* the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
	16	*
	17	* As a special exception, the Free Software Foundation gives permission
	18	* for additional uses of the text contained in its release of GUILE.
	19	*
	20	* The exception is that, if you link the GUILE library with other files
	21	* to produce an executable, this does not by itself cause the
	22	* resulting executable to be covered by the GNU General Public License.
	23	* Your use of that executable is in no way restricted on account of
	24	* linking the GUILE library code into it.
	25	*
	26	* This exception does not however invalidate any other reasons why
	27	* the executable file might be covered by the GNU General Public License.
	28	*
	29	* This exception applies only to the code released by the
	30	* Free Software Foundation under the name GUILE. If you copy
	31	* code from other Free Software Foundation releases into a copy of
	32	* GUILE, as the General Public License permits, the exception does
	33	* not apply to the code that you add in this way. To avoid misleading
	34	* anyone as to the status of such modified files, you must delete
	35	* this exception notice from them.
	36	*
	37	* If you write modifications of your own for GUILE, it is your choice
	38	* whether to permit this exception to apply to your modifications.
	39	* If you do not wish that, delete this exception notice.
	40	*/
	41	\f
	42
	43	#include <stdio.h>
	44	#include "_scm.h"
20e6290e JB	45	#include "chars.h"
	46	#include "genio.h"
	47	#include "mbstrings.h"
	48	#include "smob.h"
	49	#include "eval.h"
	50	#include "procprop.h"
	51	#include "read.h"
	52	#include "weaks.h"
	53	#include "unif.h"
0f2d19dd	54
20e6290e	55	#include "print.h"
0f2d19dd JB	56	\f
	57
	58	/* {Names of immediate symbols}
	59	*
	60	* This table must agree with the declarations in scm.h: {Immediate Symbols}.
	61	*/
	62
	63	char *scm_isymnames[] =
	64	{
	65	/* This table must agree with the declarations */
	66	"#@and",
	67	"#@begin",
	68	"#@case",
	69	"#@cond",
	70	"#@do",
	71	"#@if",
	72	"#@lambda",
	73	"#@let",
	74	"#@let*",
	75	"#@letrec",
	76	"#@or",
	77	"#@quote",
	78	"#@set!",
	79	"#@define",
	80	#if 0
	81	"#@literal-variable-ref",
	82	"#@literal-variable-set!",
	83	#endif
	84	"#@apply",
	85	"#@call-with-current-continuation",
	86
	87	/* user visible ISYMS */
	88	/* other keywords */
	89	/* Flags */
	90
	91	"#f",
	92	"#t",
	93	"#<undefined>",
	94	"#<eof>",
	95	"()",
	96	"#<unspecified>"
	97	};
	98
e6e4c9af MD	99	#ifdef DEBUG_EXTENSIONS
e6e4c9af MD	100	scm_option scm_print_opts[] = {
b7ff98dd MD	101	{ SCM_OPTION_BOOLEAN, "procnames", 0,
	102	"Print names instead of closures." },
	103	{ SCM_OPTION_SCM, "closure-hook", SCM_BOOL_F,
	104	"Procedure used to print closures." }
e6e4c9af MD	105	};
e6e4c9af MD	106
b7ff98dd	107	SCM_PROC (s_print_options, "print-options-interface", 0, 1, 0, scm_print_options);
e6e4c9af MD	108	#ifdef __STDC__
e6e4c9af MD	109	SCM
a51ea417	110	scm_print_options (SCM setting)
e6e4c9af MD	111	#else
e6e4c9af MD	112	SCM
a51ea417 MD	113	scm_print_options (setting)
a51ea417 MD	114	SCM setting;
e6e4c9af MD	115	#endif
e6e4c9af MD	116	{
a51ea417	117	SCM ans = scm_options (setting,
b7ff98dd MD	118	scm_print_opts,
	119	SCM_N_PRINT_OPTIONS,
	120	s_print_options);
e6e4c9af MD	121	return ans;
	122	}
	123	#endif
	124
0f2d19dd JB	125	\f
	126	/* {Printing of Scheme Objects}
	127	*/
	128
a51ea417 MD	129	/* Detection of circular references.
	130	*/
	131	typedef struct ref_stack {
	132	SCM vector;
	133	SCM *top;
	134	SCM *ceiling;
	135	SCM *floor;
	136	} ref_stack;
	137
	138	#define RESET_REF_STACK(stack) { stack.top = stack.floor; }
	139	#define PUSH_REF(stack, obj, label) \
	140	{ \
	141	register SCM *ref; \
	142	for (ref = stack.floor; ref < stack.top; ++ref) \
	143	if (*ref == (obj)) \
	144	goto label; \
	145	*stack.top++ = (obj); \
	146	if (stack.top == stack.ceiling) \
	147	grow_ref_stack (&stack); \
	148	} \
	149
	150	#define POP_REF(stack) { --stack.top; }
	151	#define SAVE_REF_STACK(stack, save) \
	152	{ \
	153	save = stack.floor - SCM_VELTS (stack.vector); \
	154	stack.floor = stack.top; \
	155	} \
	156
	157	#define RESTORE_REF_STACK(stack, save) \
	158	{ stack.floor = SCM_VELTS (stack.vector) + save; }
	159
	160	#ifdef __STDC__
	161	static void
	162	init_ref_stack (ref_stack *stack)
	163	#else
	164	static void
	165	init_ref_stack (stack)
	166	ref_stack *stack;
	167	#endif
	168	{
	169	stack->vector = scm_permanent_object (scm_make_vector (SCM_MAKINUM (30L),
	170	SCM_UNDEFINED,
	171	SCM_UNDEFINED));
	172	stack->top = stack->floor = SCM_VELTS (stack->vector);
	173	stack->ceiling = stack->floor + SCM_LENGTH (stack->vector);
	174	}
	175
	176	#ifdef __STDC__
	177	static void
	178	grow_ref_stack (ref_stack *stack)
	179	#else
	180	static void
	181	grow_ref_stack (stack)
	182	ref_stack *stack;
	183	#endif
	184	{
	185	int offset, new_size = 2 * SCM_LENGTH (stack->vector);
	186	SCM *old_velts = SCM_VELTS (stack->vector);
	187	scm_vector_set_length_x (stack->vector, SCM_MAKINUM (new_size));
	188	offset = SCM_VELTS (stack->vector) - old_velts;
	189	stack->top += offset;
	190	stack->floor += offset;
	191	stack->ceiling = SCM_VELTS (stack->vector) + new_size;
	192	}
193
194
0f2d19dd JB	195	/* Print generally. Handles both write and display according to WRITING.
0f2d19dd JB	196	*/
a51ea417 MD	197
	198	static ref_stack pstack;
	199
0f2d19dd JB	200	#ifdef __STDC__
	201	void
	202	scm_iprin1 (SCM exp, SCM port, int writing)
	203	#else
	204	void
	205	scm_iprin1 (exp, port, writing)
	206	SCM exp;
	207	SCM port;
	208	int writing;
	209	#endif
	210	{
	211	register long i;
	212	taloop:
	213	switch (7 & (int) exp)
	214	{
	215	case 2:
	216	case 6:
	217	scm_intprint (SCM_INUM (exp), 10, port);
	218	break;
	219	case 4:
	220	if (SCM_ICHRP (exp))
	221	{
	222	i = SCM_ICHR (exp);
	223	scm_put_wchar (i, port, writing);
	224
	225	}
a51ea417	226	else if (SCM_IFLAGP (exp)
0f2d19dd JB	227	&& (SCM_ISYMNUM (exp) < (sizeof scm_isymnames / sizeof (char *))))
	228	scm_gen_puts (scm_regular_string, SCM_ISYMSCM_CHARS (exp), port);
	229	else if (SCM_ILOCP (exp))
	230	{
	231	scm_gen_puts (scm_regular_string, "#@", port);
	232	scm_intprint ((long) SCM_IFRAME (exp), 10, port);
	233	scm_gen_putc (SCM_ICDRP (exp) ? '-' : '+', port);
	234	scm_intprint ((long) SCM_IDIST (exp), 10, port);
	235	}
	236	else
	237	goto idef;
	238	break;
	239	case 1:
	240	/* gloc */
	241	scm_gen_puts (scm_regular_string, "#@", port);
	242	exp = SCM_CAR (exp - 1);
	243	goto taloop;
	244	default:
	245	idef:
	246	scm_ipruk ("immediate", exp, port);
	247	break;
	248	case 0:
	249	switch (SCM_TYP7 (exp))
	250	{
	251	case scm_tcs_cons_gloc:
	252
	253	if (SCM_CDR (SCM_CAR (exp) - 1L) == 0)
	254	{
a51ea417	255	scm_gen_write (scm_regular_string, "#<struct ", sizeof ("#<struct ") - 1, port);
0f2d19dd JB	256	scm_intprint(exp, 16, port);
	257	scm_gen_putc ('>', port);
	258	break;
	259	}
	260
	261	case scm_tcs_cons_imcar:
	262	case scm_tcs_cons_nimcar:
a51ea417	263	PUSH_REF (pstack, exp, circref);
0f2d19dd	264	scm_iprlist ("(", exp, ')', port, writing);
a51ea417 MD	265	POP_REF (pstack);
	266	break;
	267	circref:
	268	scm_gen_write (scm_regular_string, "#<circ ref>", sizeof ("#<circ ref>") - 1, port);
0f2d19dd JB	269	break;
	270	case scm_tcs_closures:
	271	#ifdef DEBUG_EXTENSIONS
a51ea417 MD	272	if (SCM_NFALSEP (scm_procedure_p (SCM_PRINT_CLOSURE)))
	273	{
	274	SCM ans = scm_cons2 (exp, port,
	275	scm_cons (writing ? SCM_BOOL_T : SCM_BOOL_F, SCM_EOL));
	276	int save;
	277	SAVE_REF_STACK (pstack, save);
	278	ans = scm_apply (SCM_PRINT_CLOSURE, ans, SCM_EOL);
	279	RESTORE_REF_STACK (pstack, save);
	280	}
	281	else if (SCM_PRINT_PROCNAMES_P)
0f2d19dd JB	282	{
	283	SCM name;
	284	name = scm_procedure_property (exp, scm_i_name);
	285	scm_gen_puts (scm_regular_string, "#<procedure", port);
	286	if (SCM_NFALSEP (name))
	287	{
	288	scm_gen_putc (' ', port);
	289	/* FIXME */
	290	scm_gen_puts (scm_regular_string, SCM_CHARS (name), port);
	291	}
	292	scm_gen_putc ('>', port);
	293	}
	294	else
	295	#endif
	296	{
a51ea417 MD	297	SCM code = SCM_CODE (exp);
	298	exp = scm_unmemocopy (code,
	299	SCM_EXTEND_SCM_ENV (SCM_CAR (code),
	300	SCM_EOL,
	301	SCM_ENV (exp)));
0f2d19dd JB	302	scm_iprlist ("#<CLOSURE ", exp, '>', port, writing);
	303	}
	304	break;
	305	case scm_tc7_mb_string:
	306	case scm_tc7_mb_substring:
	307	scm_print_mb_string (exp, port, writing);
	308	break;
	309	case scm_tc7_substring:
	310	case scm_tc7_string:
	311	if (writing)
	312	{
	313	scm_gen_putc ('\"', port);
	314	for (i = 0; i < SCM_ROLENGTH (exp); ++i)
	315	switch (SCM_ROCHARS (exp)[i])
	316	{
	317	case '\"':
	318	case '\\':
	319	scm_gen_putc ('\\', port);
	320	default:
	321	scm_gen_putc (SCM_ROCHARS (exp)[i], port);
	322	}
	323	scm_gen_putc ('\"', port);
	324	break;
	325	}
	326	else
	327	scm_gen_write (scm_regular_string, SCM_ROCHARS (exp),
	328	(scm_sizet) SCM_ROLENGTH (exp),
	329	port);
	330	break;
	331	case scm_tcs_symbols:
	332	if (SCM_MB_STRINGP (exp))
	333	{
	334	scm_print_mb_symbol (exp, port);
	335	break;
	336	}
	337	else
	338	{
	339	int pos;
	340	int end;
	341	int len;
	342	char * str;
	343	int weird;
	344	int maybe_weird;
	345	int mw_pos;
	346
	347	len = SCM_LENGTH (exp);
	348	str = SCM_CHARS (exp);
	349	scm_remember (&exp);
	350	pos = 0;
	351	weird = 0;
	352	maybe_weird = 0;
	353
	354	if (len == 0)
	355	scm_gen_write (scm_regular_string, "#{}#", 4, port);
	356
	357	for (end = pos; end < len; ++end)
	358	switch (str[end])
	359	{
	360	#ifdef BRACKETS_AS_PARENS
	361	case '[':
	362	case ']':
	363	#endif
	364	case '(':
	365	case ')':
366	case '\"':
367	case ';':
368	case SCM_WHITE_SPACES:
369	case SCM_LINE_INCREMENTORS:
370	weird_handler:
371	if (maybe_weird)
372	{
373	end = mw_pos;
374	maybe_weird = 0;
375	}
376	if (!weird)
377	{
378	scm_gen_write (scm_regular_string, "#{", 2, port);
379	weird = 1;
380	}
381	if (pos < end)
382	{
383	scm_gen_write (scm_regular_string, str + pos, end - pos, port);
384	}
385	{
386	char buf[2];
387	buf[0] = '\\';
388	buf[1] = str[end];
389	scm_gen_write (scm_regular_string, buf, 2, port);
390	}
391	pos = end + 1;
392	break;
393	case '\\':
394	if (weird)
395	goto weird_handler;
396	if (!maybe_weird)
397	{
398	maybe_weird = 1;
399	mw_pos = pos;
400	}
401	break;
402	case '}':
403	case '#':
404	if (weird)
405	goto weird_handler;
406	break;
407	default:
408	break;
409	}
410	if (pos < end)
411	scm_gen_write (scm_regular_string, str + pos, end - pos, port);
412	if (weird)
413	scm_gen_write (scm_regular_string, "}#", 2, port);
414	break;
415	}
416	case scm_tc7_wvect:
a51ea417	417	PUSH_REF (pstack, exp, circref);
0f2d19dd JB	418	if (SCM_IS_WHVEC (exp))
	419	scm_gen_puts (scm_regular_string, "#wh(", port);
	420	else
	421	scm_gen_puts (scm_regular_string, "#w(", port);
	422	goto common_vector_printer;
	423
	424	case scm_tc7_vector:
a51ea417	425	PUSH_REF (pstack, exp, circref);
0f2d19dd JB	426	scm_gen_puts (scm_regular_string, "#(", port);
	427	common_vector_printer:
	428	for (i = 0; i + 1 < SCM_LENGTH (exp); ++i)
	429	{
	430	/* CHECK_INTS; */
	431	scm_iprin1 (SCM_VELTS (exp)[i], port, writing);
	432	scm_gen_putc (' ', port);
	433	}
	434	if (i < SCM_LENGTH (exp))
	435	{
	436	/* CHECK_INTS; */
	437	scm_iprin1 (SCM_VELTS (exp)[i], port, writing);
	438	}
	439	scm_gen_putc (')', port);
a51ea417	440	POP_REF (pstack);
0f2d19dd JB	441	break;
	442	case scm_tc7_bvect:
	443	case scm_tc7_byvect:
	444	case scm_tc7_svect:
	445	case scm_tc7_ivect:
	446	case scm_tc7_uvect:
	447	case scm_tc7_fvect:
	448	case scm_tc7_dvect:
	449	case scm_tc7_cvect:
	450	#ifdef LONGLONGS
	451	case scm_tc7_llvect:
	452	#endif
	453	scm_raprin1 (exp, port, writing);
	454	break;
	455	case scm_tcs_subrs:
	456	scm_gen_puts (scm_regular_string, "#<primitive-procedure ", port);
	457	scm_gen_puts ((SCM_MB_STRINGP (SCM_SNAME(exp))
	458	? scm_mb_string
	459	: scm_regular_string),
	460	SCM_CHARS (SCM_SNAME (exp)), port);
	461	scm_gen_putc ('>', port);
	462	break;
	463	#ifdef CCLO
	464	case scm_tc7_cclo:
	465	scm_gen_puts (scm_regular_string, "#<compiled-closure ", port);
	466	scm_iprin1 (SCM_CCLO_SUBR (exp), port, writing);
	467	scm_gen_putc ('>', port);
	468	break;
	469	#endif
	470	case scm_tc7_contin:
	471	scm_gen_puts (scm_regular_string, "#<continuation ", port);
	472	scm_intprint (SCM_LENGTH (exp), 10, port);
	473	scm_gen_puts (scm_regular_string, " @ ", port);
	474	scm_intprint ((long) SCM_CHARS (exp), 16, port);
	475	scm_gen_putc ('>', port);
	476	break;
	477	case scm_tc7_port:
	478	i = SCM_PTOBNUM (exp);
	479	if (i < scm_numptob && scm_ptobs[i].print && (scm_ptobs[i].print) (exp, port, writing))
	480	break;
	481	goto punk;
	482	case scm_tc7_smob:
a51ea417	483	PUSH_REF (pstack, exp, circref);
0f2d19dd JB	484	i = SCM_SMOBNUM (exp);
	485	if (i < scm_numsmob && scm_smobs[i].print
	486	&& (scm_smobs[i].print) (exp, port, writing))
a51ea417 MD	487	{
	488	POP_REF (pstack);
	489	break;
	490	}
	491	POP_REF (pstack);
0f2d19dd	492	default:
a51ea417 MD	493	punk:
a51ea417 MD	494	scm_ipruk ("type", exp, port);
0f2d19dd JB	495	}
	496	}
	497	}
	498
a51ea417 MD	499	#ifdef __STDC__
	500	void
	501	scm_prin1 (SCM exp, SCM port, int writing)
	502	#else
	503	void
	504	scm_prin1 (exp, port, writing)
	505	SCM exp;
	506	SCM port;
	507	int writing;
	508	#endif
	509	{
	510	RESET_REF_STACK (pstack);
	511	scm_iprin1 (exp, port, writing);
	512	}
	513
0f2d19dd JB	514
	515	/* Print an integer.
	516	*/
	517	#ifdef __STDC__
	518	void
	519	scm_intprint (long n, int radix, SCM port)
	520	#else
	521	void
	522	scm_intprint (n, radix, port)
	523	long n;
	524	int radix;
	525	SCM port;
	526	#endif
	527	{
	528	char num_buf[SCM_INTBUFLEN];
	529	scm_gen_write (scm_regular_string, num_buf, scm_iint2str (n, radix, num_buf), port);
	530	}
	531
	532	/* Print an object of unrecognized type.
	533	*/
	534	#ifdef __STDC__
	535	void
	536	scm_ipruk (char *hdr, SCM ptr, SCM port)
	537	#else
	538	void
	539	scm_ipruk (hdr, ptr, port)
	540	char *hdr;
	541	SCM ptr;
	542	SCM port;
	543	#endif
	544	{
	545	scm_gen_puts (scm_regular_string, "#<unknown-", port);
	546	scm_gen_puts (scm_regular_string, hdr, port);
	547	if (SCM_CELLP (ptr))
	548	{
	549	scm_gen_puts (scm_regular_string, " (0x", port);
	550	scm_intprint (SCM_CAR (ptr), 16, port);
	551	scm_gen_puts (scm_regular_string, " . 0x", port);
	552	scm_intprint (SCM_CDR (ptr), 16, port);
	553	scm_gen_puts (scm_regular_string, ") @", port);
	554	}
	555	scm_gen_puts (scm_regular_string, " 0x", port);
	556	scm_intprint (ptr, 16, port);
	557	scm_gen_putc ('>', port);
	558	}
	559
	560	/* Print a list.
	561	*/
a51ea417 MD	562
	563	static ref_stack lstack;
	564
0f2d19dd JB	565	#ifdef __STDC__
	566	void
	567	scm_iprlist (char *hdr, SCM exp, char tlr, SCM port, int writing)
	568	#else
	569	void
	570	scm_iprlist (hdr, exp, tlr, port, writing)
	571	char *hdr;
	572	SCM exp;
	573	char tlr;
	574	SCM port;
	575	int writing;
	576	#endif
	577	{
	578	scm_gen_puts (scm_regular_string, hdr, port);
	579	/* CHECK_INTS; */
	580	scm_iprin1 (SCM_CAR (exp), port, writing);
a51ea417 MD	581	RESET_REF_STACK (lstack);
a51ea417 MD	582	PUSH_REF (lstack, exp, circref);
0f2d19dd JB	583	exp = SCM_CDR (exp);
	584	for (; SCM_NIMP (exp); exp = SCM_CDR (exp))
	585	{
	586	if (SCM_NECONSP (exp))
	587	break;
a51ea417	588	PUSH_REF (lstack, exp, circref);
0f2d19dd JB	589	scm_gen_putc (' ', port);
	590	/* CHECK_INTS; */
	591	scm_iprin1 (SCM_CAR (exp), port, writing);
	592	}
	593	if (SCM_NNULLP (exp))
	594	{
	595	scm_gen_puts (scm_regular_string, " . ", port);
	596	scm_iprin1 (exp, port, writing);
	597	}
a51ea417	598	end:
0f2d19dd	599	scm_gen_putc (tlr, port);
a51ea417 MD	600	return;
	601	circref:
	602	scm_gen_puts (scm_regular_string, " . #<circ ref>", port);
	603	goto end;
	604	}
	605
	606	#ifdef __STDC__
	607	void
	608	scm_prlist (char *hdr, SCM exp, char tlr, SCM port, int writing)
	609	#else
	610	void
	611	scm_prlist (hdr, exp, tlr, port, writing)
	612	char *hdr;
	613	SCM exp;
	614	char tlr;
	615	SCM port;
	616	int writing;
	617	#endif
	618	{
	619	RESET_REF_STACK (pstack);
	620	scm_iprlist (hdr, exp, tlr, port, writing);
0f2d19dd JB	621	}
	622
	623	\f
	624
	625	SCM_PROC(s_write, "write", 1, 1, 0, scm_write);
	626	#ifdef __STDC__
	627	SCM
	628	scm_write (SCM obj, SCM port)
	629	#else
	630	SCM
	631	scm_write (obj, port)
	632	SCM obj;
	633	SCM port;
	634	#endif
	635	{
	636	if (SCM_UNBNDP (port))
	637	port = scm_cur_outp;
	638	else
	639	SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write);
a51ea417	640	scm_prin1 (obj, port, 1);
0f2d19dd JB	641	#ifdef HAVE_PIPE
	642	# ifdef EPIPE
	643	if (EPIPE == errno)
	644	scm_close_port (port);
	645	# endif
	646	#endif
	647	return SCM_UNSPECIFIED;
	648	}
	649
	650
	651	SCM_PROC(s_display, "display", 1, 1, 0, scm_display);
	652	#ifdef __STDC__
	653	SCM
	654	scm_display (SCM obj, SCM port)
	655	#else
	656	SCM
	657	scm_display (obj, port)
	658	SCM obj;
	659	SCM port;
	660	#endif
	661	{
	662	if (SCM_UNBNDP (port))
	663	port = scm_cur_outp;
	664	else
	665	SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_display);
a51ea417	666	scm_prin1 (obj, port, 0);
0f2d19dd JB	667	#ifdef HAVE_PIPE
	668	# ifdef EPIPE
	669	if (EPIPE == errno)
	670	scm_close_port (port);
	671	# endif
	672	#endif
	673	return SCM_UNSPECIFIED;
	674	}
	675
	676	SCM_PROC(s_newline, "newline", 0, 1, 0, scm_newline);
	677	#ifdef __STDC__
	678	SCM
	679	scm_newline(SCM port)
	680	#else
	681	SCM
	682	scm_newline (port)
	683	SCM port;
	684	#endif
	685	{
	686	if (SCM_UNBNDP (port))
	687	port = scm_cur_outp;
	688	else
	689	SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_newline);
	690	scm_gen_putc ('\n', port);
	691	#ifdef HAVE_PIPE
	692	# ifdef EPIPE
	693	if (EPIPE == errno)
	694	scm_close_port (port);
	695	else
	696	# endif
	697	#endif
	698	if (port == scm_cur_outp)
	699	scm_fflush (port);
	700	return SCM_UNSPECIFIED;
	701	}
	702
	703	SCM_PROC(s_write_char, "write-char", 1, 1, 0, scm_write_char);
	704	#ifdef __STDC__
	705	SCM
	706	scm_write_char (SCM chr, SCM port)
	707	#else
	708	SCM
	709	scm_write_char (chr, port)
	710	SCM chr;
	711	SCM port;
	712	#endif
	713	{
	714	if (SCM_UNBNDP (port))
	715	port = scm_cur_outp;
	716	else
	717	SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write_char);
	718	SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG1, s_write_char);
	719	scm_gen_putc ((int) SCM_ICHR (chr), port);
	720	#ifdef HAVE_PIPE
	721	# ifdef EPIPE
	722	if (EPIPE == errno)
	723	scm_close_port (port);
	724	# endif
	725	#endif
	726	return SCM_UNSPECIFIED;
	727	}
	728
	729
	730	\f
731
732	#ifdef __STDC__
733	void
734	scm_init_print (void)
735	#else
736	void
737	scm_init_print ()
738	#endif
739	{
e6e4c9af	740	#ifdef DEBUG_EXTENSIONS
b7ff98dd	741	scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS);
a51ea417 MD	742	init_ref_stack (&pstack);
a51ea417 MD	743	init_ref_stack (&lstack);
e6e4c9af	744	#endif
0f2d19dd JB	745	#include "print.x"
0f2d19dd JB	746	}