[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"

\f

\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>"
};

\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 (PRINT_PROCNAMES)
	    {
	      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
{
#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"
	45
	46	\f
	47
	48	\f
	49
	50	/* {Names of immediate symbols}
	51	*
	52	* This table must agree with the declarations in scm.h: {Immediate Symbols}.
	53	*/
	54
	55	char *scm_isymnames[] =
	56	{
	57	/* This table must agree with the declarations */
	58	"#@and",
	59	"#@begin",
	60	"#@case",
	61	"#@cond",
	62	"#@do",
	63	"#@if",
	64	"#@lambda",
65	"#@let",
66	"#@let*",
67	"#@letrec",
68	"#@or",
69	"#@quote",
70	"#@set!",
71	"#@define",
72	#if 0
73	"#@literal-variable-ref",
74	"#@literal-variable-set!",
75	#endif
76	"#@apply",
77	"#@call-with-current-continuation",
78
79	/* user visible ISYMS */
80	/* other keywords */
81	/* Flags */
82
83	"#f",
84	"#t",
85	"#<undefined>",
86	"#<eof>",
87	"()",
88	"#<unspecified>"
89	};
90
91	\f
92	/* {Printing of Scheme Objects}
93	*/
94
95	/* Print generally. Handles both write and display according to WRITING.
96	*/
97	#ifdef __STDC__
98	void
99	scm_iprin1 (SCM exp, SCM port, int writing)
100	#else
101	void
102	scm_iprin1 (exp, port, writing)
103	SCM exp;
104	SCM port;
105	int writing;
106	#endif
107	{
108	register long i;
109	taloop:
110	switch (7 & (int) exp)
111	{
112	case 2:
113	case 6:
114	scm_intprint (SCM_INUM (exp), 10, port);
115	break;
116	case 4:
117	if (SCM_ICHRP (exp))
118	{
119	i = SCM_ICHR (exp);
120	scm_put_wchar (i, port, writing);
121
122	}
123	else if ( SCM_IFLAGP (exp)
124	&& (SCM_ISYMNUM (exp) < (sizeof scm_isymnames / sizeof (char *))))
125	scm_gen_puts (scm_regular_string, SCM_ISYMSCM_CHARS (exp), port);
126	else if (SCM_ILOCP (exp))
127	{
128	scm_gen_puts (scm_regular_string, "#@", port);
129	scm_intprint ((long) SCM_IFRAME (exp), 10, port);
130	scm_gen_putc (SCM_ICDRP (exp) ? '-' : '+', port);
131	scm_intprint ((long) SCM_IDIST (exp), 10, port);
132	}
133	else
134	goto idef;
135	break;
136	case 1:
137	/* gloc */
138	scm_gen_puts (scm_regular_string, "#@", port);
139	exp = SCM_CAR (exp - 1);
140	goto taloop;
141	default:
142	idef:
143	scm_ipruk ("immediate", exp, port);
144	break;
145	case 0:
146	switch (SCM_TYP7 (exp))
147	{
148	case scm_tcs_cons_gloc:
149
150	if (SCM_CDR (SCM_CAR (exp) - 1L) == 0)
151	{
152	scm_gen_write (scm_regular_string, "#<struct ", (scm_sizet) 9, port);
153	scm_intprint(exp, 16, port);
154	scm_gen_putc ('>', port);
155	break;
156	}
157
158	case scm_tcs_cons_imcar:
159	case scm_tcs_cons_nimcar:
160	scm_iprlist ("(", exp, ')', port, writing);
161	break;
162	case scm_tcs_closures:
163	#ifdef DEBUG_EXTENSIONS
164	if (PRINT_PROCNAMES)
165	{
166	SCM name;
167	name = scm_procedure_property (exp, scm_i_name);
168	scm_gen_puts (scm_regular_string, "#<procedure", port);
169	if (SCM_NFALSEP (name))
170	{
171	scm_gen_putc (' ', port);
172	/* FIXME */
173	scm_gen_puts (scm_regular_string, SCM_CHARS (name), port);
174	}
175	scm_gen_putc ('>', port);
176	}
177	else
178	#endif
179	{
180	exp = SCM_CODE (exp);
181	scm_iprlist ("#<CLOSURE ", exp, '>', port, writing);
182	}
183	break;
184	case scm_tc7_mb_string:
185	case scm_tc7_mb_substring:
186	scm_print_mb_string (exp, port, writing);
187	break;
188	case scm_tc7_substring:
189	case scm_tc7_string:
190	if (writing)
191	{
192	scm_gen_putc ('\"', port);
193	for (i = 0; i < SCM_ROLENGTH (exp); ++i)
194	switch (SCM_ROCHARS (exp)[i])
195	{
196	case '\"':
197	case '\\':
198	scm_gen_putc ('\\', port);
199	default:
200	scm_gen_putc (SCM_ROCHARS (exp)[i], port);
201	}
202	scm_gen_putc ('\"', port);
203	break;
204	}
205	else
206	scm_gen_write (scm_regular_string, SCM_ROCHARS (exp),
207	(scm_sizet) SCM_ROLENGTH (exp),
208	port);
209	break;
210	case scm_tcs_symbols:
211	if (SCM_MB_STRINGP (exp))
212	{
213	scm_print_mb_symbol (exp, port);
214	break;
215	}
216	else
217	{
218	int pos;
219	int end;
220	int len;
221	char * str;
222	int weird;
223	int maybe_weird;
224	int mw_pos;
225
226	len = SCM_LENGTH (exp);
227	str = SCM_CHARS (exp);
228	scm_remember (&exp);
229	pos = 0;
230	weird = 0;
231	maybe_weird = 0;
232
233	if (len == 0)
234	scm_gen_write (scm_regular_string, "#{}#", 4, port);
235
236	for (end = pos; end < len; ++end)
237	switch (str[end])
238	{
239	#ifdef BRACKETS_AS_PARENS
240	case '[':
241	case ']':
242	#endif
243	case '(':
244	case ')':
245	case '\"':
246	case ';':
247	case SCM_WHITE_SPACES:
248	case SCM_LINE_INCREMENTORS:
249	weird_handler:
250	if (maybe_weird)
251	{
252	end = mw_pos;
253	maybe_weird = 0;
254	}
255	if (!weird)
256	{
257	scm_gen_write (scm_regular_string, "#{", 2, port);
258	weird = 1;
259	}
260	if (pos < end)
261	{
262	scm_gen_write (scm_regular_string, str + pos, end - pos, port);
263	}
264	{
265	char buf[2];
266	buf[0] = '\\';
267	buf[1] = str[end];
268	scm_gen_write (scm_regular_string, buf, 2, port);
269	}
270	pos = end + 1;
271	break;
272	case '\\':
273	if (weird)
274	goto weird_handler;
275	if (!maybe_weird)
276	{
277	maybe_weird = 1;
278	mw_pos = pos;
279	}
280	break;
281	case '}':
282	case '#':
283	if (weird)
284	goto weird_handler;
285	break;
286	default:
287	break;
288	}
289	if (pos < end)
290	scm_gen_write (scm_regular_string, str + pos, end - pos, port);
291	if (weird)
292	scm_gen_write (scm_regular_string, "}#", 2, port);
293	break;
294	}
295	case scm_tc7_wvect:
296	if (SCM_IS_WHVEC (exp))
297	scm_gen_puts (scm_regular_string, "#wh(", port);
298	else
299	scm_gen_puts (scm_regular_string, "#w(", port);
300	goto common_vector_printer;
301
302	case scm_tc7_vector:
303	scm_gen_puts (scm_regular_string, "#(", port);
304	common_vector_printer:
305	for (i = 0; i + 1 < SCM_LENGTH (exp); ++i)
306	{
307	/* CHECK_INTS; */
308	scm_iprin1 (SCM_VELTS (exp)[i], port, writing);
309	scm_gen_putc (' ', port);
310	}
311	if (i < SCM_LENGTH (exp))
312	{
313	/* CHECK_INTS; */
314	scm_iprin1 (SCM_VELTS (exp)[i], port, writing);
315	}
316	scm_gen_putc (')', port);
317	break;
318	case scm_tc7_bvect:
319	case scm_tc7_byvect:
320	case scm_tc7_svect:
321	case scm_tc7_ivect:
322	case scm_tc7_uvect:
323	case scm_tc7_fvect:
324	case scm_tc7_dvect:
325	case scm_tc7_cvect:
326	#ifdef LONGLONGS
327	case scm_tc7_llvect:
328	#endif
329	scm_raprin1 (exp, port, writing);
330	break;
331	case scm_tcs_subrs:
332	scm_gen_puts (scm_regular_string, "#<primitive-procedure ", port);
333	scm_gen_puts ((SCM_MB_STRINGP (SCM_SNAME(exp))
334	? scm_mb_string
335	: scm_regular_string),
336	SCM_CHARS (SCM_SNAME (exp)), port);
337	scm_gen_putc ('>', port);
338	break;
339	#ifdef CCLO
340	case scm_tc7_cclo:
341	scm_gen_puts (scm_regular_string, "#<compiled-closure ", port);
342	scm_iprin1 (SCM_CCLO_SUBR (exp), port, writing);
343	scm_gen_putc ('>', port);
344	break;
345	#endif
346	case scm_tc7_contin:
347	scm_gen_puts (scm_regular_string, "#<continuation ", port);
348	scm_intprint (SCM_LENGTH (exp), 10, port);
349	scm_gen_puts (scm_regular_string, " @ ", port);
350	scm_intprint ((long) SCM_CHARS (exp), 16, port);
351	scm_gen_putc ('>', port);
352	break;
353	case scm_tc7_port:
354	i = SCM_PTOBNUM (exp);
355	if (i < scm_numptob && scm_ptobs[i].print && (scm_ptobs[i].print) (exp, port, writing))
356	break;
357	goto punk;
358	case scm_tc7_smob:
359	i = SCM_SMOBNUM (exp);
360	if (i < scm_numsmob && scm_smobs[i].print
361	&& (scm_smobs[i].print) (exp, port, writing))
362	break;
363	goto punk;
364	default:
365	punk:scm_ipruk ("type", exp, port);
366	}
367	}
368	}
369
370
371	/* Print an integer.
372	*/
373	#ifdef __STDC__
374	void
375	scm_intprint (long n, int radix, SCM port)
376	#else
377	void
378	scm_intprint (n, radix, port)
379	long n;
380	int radix;
381	SCM port;
382	#endif
383	{
384	char num_buf[SCM_INTBUFLEN];
385	scm_gen_write (scm_regular_string, num_buf, scm_iint2str (n, radix, num_buf), port);
386	}
387
388	/* Print an object of unrecognized type.
389	*/
390	#ifdef __STDC__
391	void
392	scm_ipruk (char *hdr, SCM ptr, SCM port)
393	#else
394	void
395	scm_ipruk (hdr, ptr, port)
396	char *hdr;
397	SCM ptr;
398	SCM port;
399	#endif
400	{
401	scm_gen_puts (scm_regular_string, "#<unknown-", port);
402	scm_gen_puts (scm_regular_string, hdr, port);
403	if (SCM_CELLP (ptr))
404	{
405	scm_gen_puts (scm_regular_string, " (0x", port);
406	scm_intprint (SCM_CAR (ptr), 16, port);
407	scm_gen_puts (scm_regular_string, " . 0x", port);
408	scm_intprint (SCM_CDR (ptr), 16, port);
409	scm_gen_puts (scm_regular_string, ") @", port);
410	}
411	scm_gen_puts (scm_regular_string, " 0x", port);
412	scm_intprint (ptr, 16, port);
413	scm_gen_putc ('>', port);
414	}
415
416	/* Print a list.
417	*/
418	#ifdef __STDC__
419	void
420	scm_iprlist (char *hdr, SCM exp, char tlr, SCM port, int writing)
421	#else
422	void
423	scm_iprlist (hdr, exp, tlr, port, writing)
424	char *hdr;
425	SCM exp;
426	char tlr;
427	SCM port;
428	int writing;
429	#endif
430	{
431	scm_gen_puts (scm_regular_string, hdr, port);
432	/* CHECK_INTS; */
433	scm_iprin1 (SCM_CAR (exp), port, writing);
434	exp = SCM_CDR (exp);
435	for (; SCM_NIMP (exp); exp = SCM_CDR (exp))
436	{
437	if (SCM_NECONSP (exp))
438	break;
439	scm_gen_putc (' ', port);
440	/* CHECK_INTS; */
441	scm_iprin1 (SCM_CAR (exp), port, writing);
442	}
443	if (SCM_NNULLP (exp))
444	{
445	scm_gen_puts (scm_regular_string, " . ", port);
446	scm_iprin1 (exp, port, writing);
447	}
448	scm_gen_putc (tlr, port);
449	}
450
451	\f
452
453	SCM_PROC(s_write, "write", 1, 1, 0, scm_write);
454	#ifdef __STDC__
455	SCM
456	scm_write (SCM obj, SCM port)
457	#else
458	SCM
459	scm_write (obj, port)
460	SCM obj;
461	SCM port;
462	#endif
463	{
464	if (SCM_UNBNDP (port))
465	port = scm_cur_outp;
466	else
467	SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write);
468	scm_iprin1 (obj, port, 1);
469	#ifdef HAVE_PIPE
470	# ifdef EPIPE
471	if (EPIPE == errno)
472	scm_close_port (port);
473	# endif
474	#endif
475	return SCM_UNSPECIFIED;
476	}
477
478
479	SCM_PROC(s_display, "display", 1, 1, 0, scm_display);
480	#ifdef __STDC__
481	SCM
482	scm_display (SCM obj, SCM port)
483	#else
484	SCM
485	scm_display (obj, port)
486	SCM obj;
487	SCM port;
488	#endif
489	{
490	if (SCM_UNBNDP (port))
491	port = scm_cur_outp;
492	else
493	SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_display);
494	scm_iprin1 (obj, port, 0);
495	#ifdef HAVE_PIPE
496	# ifdef EPIPE
497	if (EPIPE == errno)
498	scm_close_port (port);
499	# endif
500	#endif
501	return SCM_UNSPECIFIED;
502	}
503
504	SCM_PROC(s_newline, "newline", 0, 1, 0, scm_newline);
505	#ifdef __STDC__
506	SCM
507	scm_newline(SCM port)
508	#else
509	SCM
510	scm_newline (port)
511	SCM port;
512	#endif
513	{
514	if (SCM_UNBNDP (port))
515	port = scm_cur_outp;
516	else
517	SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG1, s_newline);
518	scm_gen_putc ('\n', port);
519	#ifdef HAVE_PIPE
520	# ifdef EPIPE
521	if (EPIPE == errno)
522	scm_close_port (port);
523	else
524	# endif
525	#endif
526	if (port == scm_cur_outp)
527	scm_fflush (port);
528	return SCM_UNSPECIFIED;
529	}
530
531	SCM_PROC(s_write_char, "write-char", 1, 1, 0, scm_write_char);
532	#ifdef __STDC__
533	SCM
534	scm_write_char (SCM chr, SCM port)
535	#else
536	SCM
537	scm_write_char (chr, port)
538	SCM chr;
539	SCM port;
540	#endif
541	{
542	if (SCM_UNBNDP (port))
543	port = scm_cur_outp;
544	else
545	SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTPORTP (port), port, SCM_ARG2, s_write_char);
546	SCM_ASSERT (SCM_ICHRP (chr), chr, SCM_ARG1, s_write_char);
547	scm_gen_putc ((int) SCM_ICHR (chr), port);
548	#ifdef HAVE_PIPE
549	# ifdef EPIPE
550	if (EPIPE == errno)
551	scm_close_port (port);
552	# endif
553	#endif
554	return SCM_UNSPECIFIED;
555	}
556
557
558	\f
559
560	#ifdef __STDC__
561	void
562	scm_init_print (void)
563	#else
564	void
565	scm_init_print ()
566	#endif
567	{
568	#include "print.x"
569	}
570