-/* Copyright (C) 1995-1999, 2000 Free Software Foundation, Inc.
+/* Copyright (C) 1995-1999, 2000, 2001 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
\f
-#include <stdio.h>
+#include <errno.h>
+
#include "libguile/_scm.h"
#include "libguile/chars.h"
+#include "libguile/continuations.h"
#include "libguile/smob.h"
#include "libguile/eval.h"
#include "libguile/macros.h"
SCM_DEFINE (scm_print_options, "print-options-interface", 0, 1, 0,
(SCM setting),
-"")
+ "Option interface for the print options. Instead of using\n"
+ "this procedure directly, use the procedures\n"
+ "@code{print-enable}, @code{print-disable}, @code{print-set!}\n"
+ "and @code{print-options}.")
#define FUNC_NAME s_scm_print_options
{
SCM ans = scm_options (setting,
SCM_INUM0,
SCM_EOL);
scm_print_state *pstate = SCM_PRINT_STATE (print_state);
- pstate->ref_vect = scm_make_vector (SCM_MAKINUM (PSTATE_SIZE),
- SCM_UNDEFINED);
+ pstate->ref_vect = scm_c_make_vector (PSTATE_SIZE, SCM_UNDEFINED);
pstate->ref_stack = SCM_VELTS (pstate->ref_vect);
- pstate->ceiling = SCM_LENGTH (pstate->ref_vect);
+ pstate->ceiling = SCM_VECTOR_LENGTH (pstate->ref_vect);
return print_state;
}
static void
grow_ref_stack (scm_print_state *pstate)
{
- int new_size = 2 * pstate->ceiling;
- scm_vector_set_length_x (pstate->ref_vect, SCM_MAKINUM (new_size));
- pstate->ref_stack = SCM_VELTS (pstate->ref_vect);
+ unsigned long int old_size = SCM_VECTOR_LENGTH (pstate->ref_vect);
+ SCM *old_elts = SCM_VELTS (pstate->ref_vect);
+ unsigned long int new_size = 2 * pstate->ceiling;
+ SCM new_vect = scm_c_make_vector (new_size, SCM_UNDEFINED);
+ SCM *new_elts = SCM_VELTS (new_vect);
+ unsigned long int i;
+
+ for (i = 0; i != old_size; ++i)
+ new_elts [i] = old_elts [i];
+
+ pstate->ref_vect = new_vect;
+ pstate->ref_stack = new_elts;
pstate->ceiling = new_size;
}
taloop:
switch (SCM_ITAG3 (exp))
{
- case 2:
- case 6:
+ case scm_tc3_closure:
+ case scm_tc3_tc7_1:
+ case scm_tc3_tc7_2:
+ /* These tc3 tags should never occur in an immediate value. They are
+ * only used in cell types of non-immediates, i. e. the value returned
+ * by SCM_CELL_TYPE (exp) can use these tags.
+ */
+ scm_ipruk ("immediate", exp, port);
+ break;
+ case scm_tc3_int_1:
+ case scm_tc3_int_2:
scm_intprint (SCM_INUM (exp), 10, port);
break;
- case 4:
+ case scm_tc3_imm24:
if (SCM_CHARP (exp))
{
- register long i;
+ long i = SCM_CHAR (exp);
- i = SCM_CHAR (exp);
if (SCM_WRITINGP (pstate))
{
scm_puts ("#\\", port);
if ((i >= 0) && (i <= ' ') && scm_charnames[i])
scm_puts (scm_charnames[i], port);
+#ifndef EBCDIC
+ else if (i == '\177')
+ scm_puts (scm_charnames[scm_n_charnames - 1], port);
+#endif
else if (i < 0 || i > '\177')
scm_intprint (i, 8, port);
else
scm_intprint (SCM_IDIST (exp), 10, port);
}
else
- goto idef;
+ {
+ /* unknown immediate value */
+ scm_ipruk ("immediate", exp, port);
+ }
break;
- case 1:
+ case scm_tc3_cons_gloc:
/* gloc */
scm_puts ("#@", port);
exp = SCM_GLOC_SYM (exp);
goto taloop;
- default:
- idef:
- scm_ipruk ("immediate", exp, port);
- break;
- case 0:
+ case scm_tc3_cons:
switch (SCM_TYP7 (exp))
{
case scm_tcs_cons_gloc:
env = SCM_ENV (exp);
scm_puts ("#<procedure", port);
}
- if (SCM_ROSTRINGP (name))
+ if (SCM_SYMBOLP (name))
+ {
+ scm_putc (' ', port);
+ scm_lfwrite (SCM_SYMBOL_CHARS (name), SCM_SYMBOL_LENGTH (name), port);
+ }
+ else if (SCM_STRINGP (name))
{
scm_putc (' ', port);
- scm_puts (SCM_ROCHARS (name), port);
+ scm_lfwrite (SCM_STRING_CHARS (name), SCM_STRING_LENGTH (name), port);
}
if (!SCM_UNBNDP (code))
{
scm_sizet i;
scm_putc ('"', port);
- for (i = 0; i < SCM_ROLENGTH (exp); ++i)
- switch (SCM_ROCHARS (exp)[i])
+ for (i = 0; i < SCM_STRING_LENGTH (exp); ++i)
+ switch (SCM_STRING_CHARS (exp)[i])
{
case '"':
case '\\':
scm_putc ('\\', port);
default:
- scm_putc (SCM_ROCHARS (exp)[i], port);
+ scm_putc (SCM_STRING_CHARS (exp)[i], port);
}
scm_putc ('"', port);
break;
}
else
- scm_lfwrite (SCM_ROCHARS (exp), (scm_sizet) SCM_ROLENGTH (exp),
- port);
+ scm_lfwrite (SCM_STRING_CHARS (exp), SCM_STRING_LENGTH (exp), port);
break;
- case scm_tcs_symbols:
+ case scm_tc7_symbol:
{
int pos;
int end;
int maybe_weird;
int mw_pos = 0;
- len = SCM_LENGTH (exp);
- str = SCM_CHARS (exp);
- scm_remember (&exp);
+ len = SCM_SYMBOL_LENGTH (exp);
+ str = SCM_SYMBOL_CHARS (exp);
pos = 0;
weird = 0;
maybe_weird = 0;
}
if (pos < end)
scm_lfwrite (str + pos, end - pos, port);
+ scm_remember_upto_here_1 (exp);
if (weird)
scm_lfwrite ("}#", 2, port);
break;
common_vector_printer:
{
register long i;
- int last = SCM_LENGTH (exp) - 1;
+ int last = SCM_VECTOR_LENGTH (exp) - 1;
int cutp = 0;
- if (pstate->fancyp && SCM_LENGTH (exp) > pstate->length)
+ if (pstate->fancyp && SCM_VECTOR_LENGTH (exp) > pstate->length)
{
last = pstate->length - 1;
cutp = 1;
? "#<primitive-generic "
: "#<primitive-procedure ",
port);
- scm_puts (SCM_CHARS (SCM_SNAME (exp)), port);
+ scm_puts (SCM_SYMBOL_CHARS (SCM_SNAME (exp)), port);
scm_putc ('>', port);
break;
#ifdef CCLO
if (SCM_NFALSEP (name))
{
scm_putc (' ', port);
- scm_puts (SCM_CHARS (name), port);
+ scm_puts (SCM_SYMBOL_CHARS (name), port);
}
}
else
if (SCM_NFALSEP (name))
{
scm_putc (' ', port);
- scm_puts (SCM_ROCHARS (name), port);
+ scm_display (name, port);
}
}
scm_putc ('>', port);
break;
- case scm_tc7_contin:
- scm_puts ("#<continuation ", port);
- scm_intprint (SCM_LENGTH (exp), 10, port);
- scm_puts (" @ ", port);
- scm_intprint ((long) SCM_CHARS (exp), 16, port);
- scm_putc ('>', port);
- break;
case scm_tc7_port:
{
register long i = SCM_PTOBNUM (exp);
SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1,
(SCM destination, SCM message, SCM args),
- "Write MESSAGE to DESTINATION, defaulting to `current-output-port'.\n"
- "MESSAGE can contain ~A (was %s) and ~S (was %S) escapes. When printed,\n"
- "the escapes are replaced with corresponding members of ARGS:\n"
- "~A formats using `display' and ~S formats using `write'.\n"
- "If DESTINATION is #t, then use the `current-output-port',\n"
- "if DESTINATION is #f, then return a string containing the formatted text.\n"
- "Does not add a trailing newline.")
+ "Write @var{message} to @var{destination}, defaulting to\n"
+ "the current output port.\n"
+ "@var{message} can contain @code{~A} (was @code{%s}) and\n"
+ "@code{~S} (was @code{%S}) escapes. When printed,\n"
+ "the escapes are replaced with corresponding members of\n"
+ "@var{ARGS}:\n"
+ "@code{~A} formats using @code{display} and @code{~S} formats\n"
+ "using @code{write}.\n"
+ "If @var{destination} is @code{#t}, then use the current output\n"
+ "port, if @var{destination} is @code{#f}, then return a string\n"
+ "containing the formatted text. Does not add a trailing newline.")
#define FUNC_NAME s_scm_simple_format
{
SCM answer = SCM_UNSPECIFIED;
int fReturnString = 0;
int writingp;
char *start;
+ char *end;
char *p;
- if (SCM_EQ_P (destination, SCM_BOOL_T)) {
- destination = scm_cur_outp;
- } else if (SCM_FALSEP (destination)) {
- fReturnString = 1;
- destination = scm_mkstrport (SCM_INUM0,
- scm_make_string (SCM_INUM0, SCM_UNDEFINED),
- SCM_OPN | SCM_WRTNG,
- FUNC_NAME);
- } else {
- SCM_VALIDATE_OPORT_VALUE (1,destination);
- }
- SCM_VALIDATE_STRING(2,message);
+ if (SCM_EQ_P (destination, SCM_BOOL_T))
+ {
+ destination = scm_cur_outp;
+ }
+ else if (SCM_FALSEP (destination))
+ {
+ fReturnString = 1;
+ destination = scm_mkstrport (SCM_INUM0,
+ scm_make_string (SCM_INUM0, SCM_UNDEFINED),
+ SCM_OPN | SCM_WRTNG,
+ FUNC_NAME);
+ }
+ else
+ {
+ SCM_VALIDATE_OPORT_VALUE (1, destination);
+ destination = SCM_COERCE_OUTPORT (destination);
+ }
+ SCM_VALIDATE_STRING (2, message);
SCM_VALIDATE_REST_ARGUMENT (args);
- start = SCM_ROCHARS (message);
- for (p = start; *p != '\0'; ++p)
+ start = SCM_STRING_CHARS (message);
+ end = start + SCM_STRING_LENGTH (message);
+ for (p = start; p != end; ++p)
if (*p == '~')
{
- if (SCM_IMP (args) || SCM_NCONSP (args))
+ if (!SCM_CONSP (args))
continue;
- ++p;
- if (*p == 'A')
+ if (++p == end)
+ continue;
+
+ if (*p == 'A' || *p == 'a')
writingp = 0;
- else if (*p == 'S')
+ else if (*p == 'S' || *p == 's')
writingp = 1;
else
continue;
if (fReturnString)
answer = scm_strport_to_string (destination);
- return scm_return_first(answer,message);
+ return scm_return_first (answer, message);
}
#undef FUNC_NAME
SCM_DEFINE (scm_newline, "newline", 0, 1, 0,
(SCM port),
- "Send a newline to PORT.")
+ "Send a newline to @var{port}.")
#define FUNC_NAME s_scm_newline
{
if (SCM_UNBNDP (port))
SCM_DEFINE (scm_write_char, "write-char", 1, 1, 0,
(SCM chr, SCM port),
- "Send character CHR to PORT.")
+ "Send character @var{chr} to @var{port}.")
#define FUNC_NAME s_scm_write_char
{
if (SCM_UNBNDP (port))
* escaped to Scheme and thus has to be freed by the GC.
*/
-long scm_tc16_port_with_ps;
+scm_bits_t scm_tc16_port_with_ps;
/* Print exactly as the port itself would */
static int
-print_port_with_ps (SCM obj, SCM port, scm_print_state *pstate)
+port_with_ps_print (SCM obj, SCM port, scm_print_state *pstate)
{
obj = SCM_PORT_WITH_PS_PORT (obj);
return scm_ptobs[SCM_PTOBNUM (obj)].print (obj, port, pstate);
SCM_DEFINE (scm_port_with_print_state, "port-with-print-state", 2, 0, 0,
(SCM port, SCM pstate),
- "")
+ "Create a new port which behaves like @var{port}, but with an\n"
+ "included print state @var{pstate}.")
#define FUNC_NAME s_scm_port_with_print_state
{
SCM pwps;
SCM_DEFINE (scm_get_print_state, "get-print-state", 1, 0, 0,
(SCM port),
- "")
+ "Return the print state of the port @var{port}. If @var{port}\n"
+ "has no associated print state, @code{#f} is returned.")
#define FUNC_NAME s_scm_get_print_state
{
if (SCM_PORT_WITH_PS_P (port))
return SCM_PORT_WITH_PS_PS (port);
if (SCM_OUTPUT_PORT_P (port))
return SCM_BOOL_F;
- RETURN_SCM_WTA (1,port);
+ SCM_WRONG_TYPE_ARG (1, port);
}
#undef FUNC_NAME
SCM vtable, layout, type;
scm_init_opts (scm_print_options, scm_print_opts, SCM_N_PRINT_OPTIONS);
- vtable = scm_make_vtable_vtable (scm_make_struct_layout (scm_nullstr),
- SCM_INUM0,
- SCM_EOL);
+ vtable = scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL);
layout = scm_make_struct_layout (scm_makfrom0str (SCM_PRINT_STATE_LAYOUT));
type = scm_make_struct (vtable, SCM_INUM0, SCM_LIST1 (layout));
- scm_set_struct_vtable_name_x (type, SCM_CAR (scm_intern0 ("print-state")));
+ scm_set_struct_vtable_name_x (type, scm_str2symbol ("print-state"));
print_state_pool = scm_permanent_object (scm_cons (type, SCM_EOL));
scm_print_state_vtable = type;
/* Don't want to bind a wrapper class in GOOPS, so pass 0 as arg1. */
scm_tc16_port_with_ps = scm_make_smob_type (0, 0);
scm_set_smob_mark (scm_tc16_port_with_ps, scm_markcdr);
- scm_set_smob_print (scm_tc16_port_with_ps, print_port_with_ps);
+ scm_set_smob_print (scm_tc16_port_with_ps, port_with_ps_print);
+#ifndef SCM_MAGIC_SNARFER
#include "libguile/print.x"
+#endif
}
/*
HCoop / bpt / guile.git / blobdiff