[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 new_values)
#else
SCM
scm_print_options (new_values)
     SCM new_values;
#endif
{
  SCM ans = scm_options (new_values,
			 scm_print_opts,
			 SCM_N_PRINT_OPTIONS,
			 s_print_options);
  return ans;
}
#endif

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

/* Print generally.  Handles both write and display according to WRITING.
 */
#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 ", (scm_sizet) 9, port);
	      scm_intprint(exp, 16, port);
	      scm_gen_putc ('>', port);
	      break;
	    }

	case scm_tcs_cons_imcar:
	case scm_tcs_cons_nimcar:
	  scm_iprlist ("(", exp, ')', port, writing);
	  break;
	case scm_tcs_closures:
#ifdef DEBUG_EXTENSIONS
	  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
	    {
	      exp = SCM_CODE (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:
	  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:
	  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);
	  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:
	  i = SCM_SMOBNUM (exp);
	  if (i < scm_numsmob && scm_smobs[i].print
	      && (scm_smobs[i].print) (exp, port, writing))
	    break;
	  goto punk;
	default:
	punk:scm_ipruk ("type", exp, port);
	}
    }
}


/* 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.
 */
#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);
  exp = SCM_CDR (exp);
  for (; SCM_NIMP (exp); exp = SCM_CDR (exp))
    {
      if (SCM_NECONSP (exp))
	break;
      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);
    }
  scm_gen_putc (tlr, port);
}

\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_iprin1 (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_iprin1 (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);
#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__
	109	SCM
	110	scm_print_options (SCM new_values)
	111	#else
	112	SCM
	113	scm_print_options (new_values)
	114	SCM new_values;
	115	#endif
	116	{
b7ff98dd MD	117	SCM ans = scm_options (new_values,
	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
	129	/* Print generally. Handles both write and display according to WRITING.
	130	*/
	131	#ifdef __STDC__
	132	void
	133	scm_iprin1 (SCM exp, SCM port, int writing)
	134	#else
	135	void
	136	scm_iprin1 (exp, port, writing)
	137	SCM exp;
	138	SCM port;
	139	int writing;
	140	#endif
	141	{
	142	register long i;
	143	taloop:
	144	switch (7 & (int) exp)
	145	{
	146	case 2:
	147	case 6:
	148	scm_intprint (SCM_INUM (exp), 10, port);
	149	break;
	150	case 4:
	151	if (SCM_ICHRP (exp))
	152	{
	153	i = SCM_ICHR (exp);
	154	scm_put_wchar (i, port, writing);
	155
	156	}
	157	else if ( SCM_IFLAGP (exp)
	158	&& (SCM_ISYMNUM (exp) < (sizeof scm_isymnames / sizeof (char *))))
	159	scm_gen_puts (scm_regular_string, SCM_ISYMSCM_CHARS (exp), port);
	160	else if (SCM_ILOCP (exp))
	161	{
	162	scm_gen_puts (scm_regular_string, "#@", port);
	163	scm_intprint ((long) SCM_IFRAME (exp), 10, port);
	164	scm_gen_putc (SCM_ICDRP (exp) ? '-' : '+', port);
	165	scm_intprint ((long) SCM_IDIST (exp), 10, port);
	166	}
	167	else
	168	goto idef;
	169	break;
	170	case 1:
	171	/* gloc */
	172	scm_gen_puts (scm_regular_string, "#@", port);
	173	exp = SCM_CAR (exp - 1);
	174	goto taloop;
	175	default:
	176	idef:
	177	scm_ipruk ("immediate", exp, port);
	178	break;
	179	case 0:
	180	switch (SCM_TYP7 (exp))
	181	{
	182	case scm_tcs_cons_gloc:
	183
	184	if (SCM_CDR (SCM_CAR (exp) - 1L) == 0)
	185	{
	186	scm_gen_write (scm_regular_string, "#<struct ", (scm_sizet) 9, port);
	187	scm_intprint(exp, 16, port);
	188	scm_gen_putc ('>', port);
189	break;
190	}
191
192	case scm_tcs_cons_imcar:
193	case scm_tcs_cons_nimcar:
194	scm_iprlist ("(", exp, ')', port, writing);
195	break;
196	case scm_tcs_closures:
197	#ifdef DEBUG_EXTENSIONS
b7ff98dd	198	if (SCM_PRINT_PROCNAMES_P)
0f2d19dd JB	199	{
	200	SCM name;
	201	name = scm_procedure_property (exp, scm_i_name);
	202	scm_gen_puts (scm_regular_string, "#<procedure", port);
	203	if (SCM_NFALSEP (name))
	204	{
	205	scm_gen_putc (' ', port);
	206	/* FIXME */
	207	scm_gen_puts (scm_regular_string, SCM_CHARS (name), port);
	208	}
	209	scm_gen_putc ('>', port);
	210	}
	211	else
	212	#endif
	213	{
	214	exp = SCM_CODE (exp);
	215	scm_iprlist ("#<CLOSURE ", exp, '>', port, writing);
	216	}
	217	break;
	218	case scm_tc7_mb_string:
	219	case scm_tc7_mb_substring:
	220	scm_print_mb_string (exp, port, writing);
	221	break;
	222	case scm_tc7_substring:
	223	case scm_tc7_string:
	224	if (writing)
	225	{
	226	scm_gen_putc ('\"', port);
	227	for (i = 0; i < SCM_ROLENGTH (exp); ++i)
	228	switch (SCM_ROCHARS (exp)[i])
	229	{
	230	case '\"':
	231	case '\\':
	232	scm_gen_putc ('\\', port);
	233	default:
	234	scm_gen_putc (SCM_ROCHARS (exp)[i], port);
	235	}
	236	scm_gen_putc ('\"', port);
	237	break;
	238	}
	239	else
	240	scm_gen_write (scm_regular_string, SCM_ROCHARS (exp),
	241	(scm_sizet) SCM_ROLENGTH (exp),
	242	port);
	243	break;
	244	case scm_tcs_symbols:
	245	if (SCM_MB_STRINGP (exp))
	246	{
	247	scm_print_mb_symbol (exp, port);
	248	break;
	249	}
	250	else
	251	{
	252	int pos;
	253	int end;
	254	int len;
	255	char * str;
	256	int weird;
	257	int maybe_weird;
	258	int mw_pos;
	259
	260	len = SCM_LENGTH (exp);
	261	str = SCM_CHARS (exp);
	262	scm_remember (&exp);
263	pos = 0;
264	weird = 0;
265	maybe_weird = 0;
266
267	if (len == 0)
268	scm_gen_write (scm_regular_string, "#{}#", 4, port);
269
270	for (end = pos; end < len; ++end)
271	switch (str[end])
272	{
273	#ifdef BRACKETS_AS_PARENS
274	case '[':
275	case ']':
276	#endif
277	case '(':
278	case ')':
279	case '\"':
280	case ';':
281	case SCM_WHITE_SPACES:
282	case SCM_LINE_INCREMENTORS:
283	weird_handler:
284	if (maybe_weird)
285	{
286	end = mw_pos;
287	maybe_weird = 0;
288	}
289	if (!weird)
290	{
291	scm_gen_write (scm_regular_string, "#{", 2, port);
292	weird = 1;
293	}
294	if (pos < end)
295	{
296	scm_gen_write (scm_regular_string, str + pos, end - pos, port);
297	}
298	{
299	char buf[2];
300	buf[0] = '\\';
301	buf[1] = str[end];
302	scm_gen_write (scm_regular_string, buf, 2, port);
303	}
304	pos = end + 1;
305	break;
306	case '\\':
307	if (weird)
308	goto weird_handler;
309	if (!maybe_weird)
310	{
311	maybe_weird = 1;
312	mw_pos = pos;
313	}
314	break;
315	case '}':
316	case '#':
317	if (weird)
318	goto weird_handler;
319	break;
320	default:
321	break;
322	}
323	if (pos < end)
324	scm_gen_write (scm_regular_string, str + pos, end - pos, port);
325	if (weird)
326	scm_gen_write (scm_regular_string, "}#", 2, port);
327	break;
328	}
329	case scm_tc7_wvect:
330	if (SCM_IS_WHVEC (exp))
331	scm_gen_puts (scm_regular_string, "#wh(", port);
332	else
333	scm_gen_puts (scm_regular_string, "#w(", port);
334	goto common_vector_printer;
335
336	case scm_tc7_vector:
337	scm_gen_puts (scm_regular_string, "#(", port);
338	common_vector_printer:
339	for (i = 0; i + 1 < SCM_LENGTH (exp); ++i)
340	{
341	/* CHECK_INTS; */
342	scm_iprin1 (SCM_VELTS (exp)[i], port, writing);
343	scm_gen_putc (' ', port);
344	}
345	if (i < SCM_LENGTH (exp))
346	{
347	/* CHECK_INTS; */
348	scm_iprin1 (SCM_VELTS (exp)[i], port, writing);
349	}
350	scm_gen_putc (')', port);
351	break;
352	case scm_tc7_bvect:
353	case scm_tc7_byvect:
354	case scm_tc7_svect:
355	case scm_tc7_ivect:
356	case scm_tc7_uvect:
357	case scm_tc7_fvect:
358	case scm_tc7_dvect:
359	case scm_tc7_cvect:
360	#ifdef LONGLONGS
361	case scm_tc7_llvect:
362	#endif
363	scm_raprin1 (exp, port, writing);
364	break;
365	case scm_tcs_subrs:
366	scm_gen_puts (scm_regular_string, "#<primitive-procedure ", port);
367	scm_gen_puts ((SCM_MB_STRINGP (SCM_SNAME(exp))
368	? scm_mb_string
369	: scm_regular_string),
370	SCM_CHARS (SCM_SNAME (exp)), port);
371	scm_gen_putc ('>', port);
372	break;
373	#ifdef CCLO
374	case scm_tc7_cclo:
375	scm_gen_puts (scm_regular_string, "#<compiled-closure ", port);
376	scm_iprin1 (SCM_CCLO_SUBR (exp), port, writing);
377	scm_gen_putc ('>', port);
378	break;
379	#endif
380	case scm_tc7_contin:
381	scm_gen_puts (scm_regular_string, "#<continuation ", port);
382	scm_intprint (SCM_LENGTH (exp), 10, port);
383	scm_gen_puts (scm_regular_string, " @ ", port);
384	scm_intprint ((long) SCM_CHARS (exp), 16, port);
385	scm_gen_putc ('>', port);
386	break;
387	case scm_tc7_port:
388	i = SCM_PTOBNUM (exp);
389	if (i < scm_numptob && scm_ptobs[i].print && (scm_ptobs[i].print) (exp, port, writing))
390	break;
391	goto punk;
392	case scm_tc7_smob:
393	i = SCM_SMOBNUM (exp);
394	if (i < scm_numsmob && scm_smobs[i].print
395	&& (scm_smobs[i].print) (exp, port, writing))
396	break;
397	goto punk;
398	default:
399	punk:scm_ipruk ("type", exp, port);
400	}
401	}
402	}
403
404
405	/* Print an integer.
406	*/
407	#ifdef __STDC__
408	void
409	scm_intprint (long n, int radix, SCM port)
410	#else
411	void
412	scm_intprint (n, radix, port)
413	long n;
414	int radix;
415	SCM port;
416	#endif
417	{
418	char num_buf[SCM_INTBUFLEN];
419	scm_gen_write (scm_regular_string, num_buf, scm_iint2str (n, radix, num_buf), port);
420	}
421
422	/* Print an object of unrecognized type.
423	*/
424	#ifdef __STDC__
425	void
426	scm_ipruk (char *hdr, SCM ptr, SCM port)
427	#else
428	void
429	scm_ipruk (hdr, ptr, port)
430	char *hdr;
431	SCM ptr;
432	SCM port;
433	#endif
434	{
435	scm_gen_puts (scm_regular_string, "#<unknown-", port);
436	scm_gen_puts (scm_regular_string, hdr, port);
437	if (SCM_CELLP (ptr))
438	{
439	scm_gen_puts (scm_regular_string, " (0x", port);
440	scm_intprint (SCM_CAR (ptr), 16, port);
441	scm_gen_puts (scm_regular_string, " . 0x", port);
442	scm_intprint (SCM_CDR (ptr), 16, port);
443	scm_gen_puts (scm_regular_string, ") @", port);
444	}
445	scm_gen_puts (scm_regular_string, " 0x", port);
446	scm_intprint (ptr, 16, port);
447	scm_gen_putc ('>', port);
448	}
449
450	/* Print a list.
451	*/
452	#ifdef __STDC__
453	void
454	scm_iprlist (char *hdr, SCM exp, char tlr, SCM port, int writing)
455	#else
456	void
457	scm_iprlist (hdr, exp, tlr, port, writing)
458	char *hdr;
459	SCM exp;
460	char tlr;
461	SCM port;
462	int writing;
463	#endif
464	{
465	scm_gen_puts (scm_regular_string, hdr, port);
466	/* CHECK_INTS; */
467	scm_iprin1 (SCM_CAR (exp), port, writing);
468	exp = SCM_CDR (exp);
469	for (; SCM_NIMP (exp); exp = SCM_CDR (exp))
470	{
471	if (SCM_NECONSP (exp))
472	break;
473	scm_gen_putc (' ', port);
474	/* CHECK_INTS; */
475	scm_iprin1 (SCM_CAR (exp), port, writing);
476	}
477	if (SCM_NNULLP (exp))
478	{
479	scm_gen_puts (scm_regular_string, " . ", port);
480	scm_iprin1 (exp, port, writing);
481	}
482	scm_gen_putc (tlr, port);
483	}
484
485	\f
486
487	SCM_PROC(s_write, "write", 1, 1, 0, scm_write);
488	#ifdef __STDC__
489	SCM
490	scm_write (SCM obj, SCM port)
491	#else
492	SCM
493	scm_write (obj, port)
494	SCM obj;
495	SCM port;
496	#endif
497	{
498	if (SCM_UNBNDP (port))
499	port = scm_cur_outp;
500	else
501	SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write);
502	scm_iprin1 (obj, port, 1);
503	#ifdef HAVE_PIPE
504	# ifdef EPIPE
505	if (EPIPE == errno)
506	scm_close_port (port);
507	# endif
508	#endif
509	return SCM_UNSPECIFIED;
510	}
511
512
513	SCM_PROC(s_display, "display", 1, 1, 0, scm_display);
514	#ifdef __STDC__
515	SCM
516	scm_display (SCM obj, SCM port)
517	#else
518	SCM
519	scm_display (obj, port)
520	SCM obj;
521	SCM port;
522	#endif
523	{
524	if (SCM_UNBNDP (port))
525	port = scm_cur_outp;
526	else
527	SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_display);
528	scm_iprin1 (obj, port, 0);
529	#ifdef HAVE_PIPE
530	# ifdef EPIPE
531	if (EPIPE == errno)
532	scm_close_port (port);
533	# endif
534	#endif
535	return SCM_UNSPECIFIED;
536	}
537
538	SCM_PROC(s_newline, "newline", 0, 1, 0, scm_newline);
539	#ifdef __STDC__
540	SCM
541	scm_newline(SCM port)
542	#else
543	SCM
544	scm_newline (port)
545	SCM port;
546	#endif
547	{
548	if (SCM_UNBNDP (port))
549	port = scm_cur_outp;
550	else
551	SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_newline);
552	scm_gen_putc ('\n', port);
553	#ifdef HAVE_PIPE
554	# ifdef EPIPE
555	if (EPIPE == errno)
556	scm_close_port (port);
557	else
558	# endif
559	#endif
560	if (port == scm_cur_outp)
561	scm_fflush (port);
562	return SCM_UNSPECIFIED;
563	}
564
565	SCM_PROC(s_write_char, "write-char", 1, 1, 0, scm_write_char);
566	#ifdef __STDC__
567	SCM
568	scm_write_char (SCM chr, SCM port)
569	#else
570	SCM
571	scm_write_char (chr, port)
572	SCM chr;
573	SCM port;
574	#endif
575	{
576	if (SCM_UNBNDP (port))
577	port = scm_cur_outp;
578	else
579	SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write_char);
580	SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG1, s_write_char);
581	scm_gen_putc ((int) SCM_ICHR (chr), port);
582	#ifdef HAVE_PIPE
583	# ifdef EPIPE
584	if (EPIPE == errno)
585	scm_close_port (port);
586	# endif
587	#endif
588	return SCM_UNSPECIFIED;
589	}
590
591
592	\f
593
594	#ifdef __STDC__
595	void
596	scm_init_print (void)
597	#else
598	void
599	scm_init_print ()
600	#endif
601	{
e6e4c9af	602	#ifdef DEBUG_EXTENSIONS
b7ff98dd	603	scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS);
e6e4c9af	604	#endif
0f2d19dd JB	605	#include "print.x"
	606	}
	607