-/* Copyright (C) 1995-1999 Free Software Foundation, Inc.
+/* Copyright (C) 1995-1999, 2000 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
\f
#include <stdio.h>
-#include "_scm.h"
-#include "chars.h"
-#include "smob.h"
-#include "eval.h"
-#include "macros.h"
-#include "procprop.h"
-#include "read.h"
-#include "weaks.h"
-#include "unif.h"
-#include "alist.h"
-#include "struct.h"
-#include "objects.h"
-#include "ports.h"
-#include "root.h"
-#include "strings.h"
-#include "strports.h"
-#include "vectors.h"
-
-#include "validate.h"
-#include "print.h"
+#include "libguile/_scm.h"
+#include "libguile/chars.h"
+#include "libguile/smob.h"
+#include "libguile/eval.h"
+#include "libguile/macros.h"
+#include "libguile/procprop.h"
+#include "libguile/read.h"
+#include "libguile/weaks.h"
+#include "libguile/unif.h"
+#include "libguile/alist.h"
+#include "libguile/struct.h"
+#include "libguile/objects.h"
+#include "libguile/ports.h"
+#include "libguile/root.h"
+#include "libguile/strings.h"
+#include "libguile/strports.h"
+#include "libguile/vectors.h"
+
+#include "libguile/validate.h"
+#include "libguile/print.h"
\f
/* {Names of immediate symbols}
/* Detection of circular references.
*
* Due to other constraints in the implementation, this code has bad
- * time complexity (O (depth * N)), The printer code will be
- * completely rewritten before next release of Guile. The new code
- * will be O(N).
+ * time complexity (O (depth * N)), The printer code can be
+ * rewritten to be O(N).
*/
#define PUSH_REF(pstate, obj) \
do { \
do { \
register unsigned long i; \
for (i = 0; i < pstate->top; ++i) \
- if (pstate->ref_stack[i] == (obj)) \
+ if (SCM_EQ_P (pstate->ref_stack[i], (obj))) \
goto label; \
if (pstate->fancyp) \
{ \
"`current-pstate' is only included in GUILE_DEBUG builds.")
#define FUNC_NAME s_scm_current_pstate
{
- return SCM_CADR (print_state_pool);
+ if (SCM_NNULLP (SCM_CDR (print_state_pool)))
+ return SCM_CADR (print_state_pool);
+ else
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM
scm_make_print_state ()
{
- SCM answer = 0;
+ SCM answer = SCM_BOOL_F;
/* First try to allocate a print state from the pool */
SCM_DEFER_INTS;
}
SCM_ALLOW_INTS;
- return answer ? answer : make_print_state ();
+ return SCM_FALSEP (answer) ? make_print_state () : answer;
}
void
while (i > 0)
{
if (SCM_NCONSP (pstate->ref_stack[i - 1])
- || SCM_CDR (pstate->ref_stack[i - 1]) != pstate->ref_stack[i])
+ || !SCM_EQ_P (SCM_CDR (pstate->ref_stack[i - 1]),
+ pstate->ref_stack[i]))
break;
--i;
}
self = i;
}
for (i = pstate->top - 1; 1; --i)
- if (pstate->ref_stack[i] == ref)
+ if (SCM_EQ_P (pstate->ref_stack[i], ref))
break;
scm_putc ('#', port);
scm_intprint (i - self, 10, port);
scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate)
{
taloop:
- switch (7 & (int) exp)
+ switch (SCM_ITAG3 (exp))
{
case 2:
case 6:
else if (SCM_ILOCP (exp))
{
scm_puts ("#@", port);
- scm_intprint ((long) SCM_IFRAME (exp), 10, port);
+ scm_intprint (SCM_IFRAME (exp), 10, port);
scm_putc (SCM_ICDRP (exp) ? '-' : '+', port);
- scm_intprint ((long) SCM_IDIST (exp), 10, port);
+ scm_intprint (SCM_IDIST (exp), 10, port);
}
else
goto idef;
{
case scm_tcs_cons_gloc:
- if (SCM_CDR ((SCM) SCM_STRUCT_VTABLE_DATA (exp)) == (SCM) 0)
+ if (SCM_STRUCT_VTABLE_DATA (exp) [scm_vtable_index_vcell] == 0)
{
ENTER_NESTED_DATA (pstate, exp, circref);
if (SCM_OBJ_CLASS_FLAGS (exp) & SCM_CLASSF_GOOPS)
goto print_struct;
SCM_NEWSMOB (pwps,
scm_tc16_port_with_ps,
- scm_cons (port, pstate->handle));
+ SCM_UNPACK (scm_cons (port, pstate->handle)));
scm_call_generic_2 (print, exp, pwps);
}
else
name = scm_macro_name (exp);
if (!SCM_CLOSUREP (SCM_CDR (exp)))
{
- code = env = 0;
+ code = env = SCM_UNDEFINED;
scm_puts ("#<primitive-", port);
}
else
env = SCM_ENV (SCM_CDR (exp));
scm_puts ("#<", port);
}
- if (SCM_UNPACK_CAR(exp) & (3L << 16))
+ if (SCM_CELL_WORD_0 (exp) & (3L << 16))
scm_puts ("macro", port);
else
scm_puts ("syntax", port);
- if (SCM_UNPACK_CAR (exp) & (2L << 16))
+ if (SCM_CELL_WORD_0 (exp) & (2L << 16))
scm_putc ('!', port);
}
else
scm_putc (' ', port);
scm_puts (SCM_ROCHARS (name), port);
}
- if (code)
+ if (!SCM_UNBNDP (code))
{
if (SCM_PRINT_SOURCE_P)
{
case scm_tc7_cclo:
{
SCM proc = SCM_CCLO_SUBR (exp);
- if (proc == scm_f_gsubr_apply)
+ if (SCM_EQ_P (proc, scm_f_gsubr_apply))
{
/* Print gsubrs as primitives */
SCM name = scm_procedure_name (exp);
SCM_SETCDR (print_state_pool, SCM_CDDR (print_state_pool));
}
SCM_ALLOW_INTS;
- if (handle == SCM_BOOL_F)
+ if (SCM_FALSEP (handle))
handle = scm_cons (make_print_state (), SCM_EOL);
pstate_scm = SCM_CAR (handle);
}
/* Return print state to pool if it has been created above and
hasn't escaped to Scheme. */
- if (handle != SCM_BOOL_F && !pstate->revealed)
+ if (!SCM_FALSEP (handle) && !pstate->revealed)
{
SCM_DEFER_INTS;
SCM_SETCDR (handle, SCM_CDR (print_state_pool));
if (SCM_CELLP (ptr))
{
scm_puts (" (0x", port);
- scm_intprint ((int) SCM_CAR (ptr), 16, port);
+ scm_intprint (SCM_CELL_WORD_0 (ptr), 16, port);
scm_puts (" . 0x", port);
- scm_intprint ((int) SCM_CDR (ptr), 16, port);
+ scm_intprint (SCM_CELL_WORD_1 (ptr), 16, port);
scm_puts (") @", port);
}
scm_puts (" 0x", port);
- scm_intprint ((int) ptr, 16, port);
+ scm_intprint (SCM_UNPACK (ptr), 16, port);
scm_putc ('>', port);
}
tortoise = exp;
while (SCM_ECONSP (hare))
{
- if (hare == tortoise)
+ if (SCM_EQ_P (hare, tortoise))
goto fancy_printing;
hare = SCM_CDR (hare);
if (SCM_IMP (hare) || SCM_NECONSP (hare))
if (SCM_NECONSP (exp))
break;
for (i = floor; i >= 0; --i)
- if (pstate->ref_stack[i] == exp)
+ if (SCM_EQ_P (pstate->ref_stack[i], exp))
goto circref;
PUSH_REF (pstate, exp);
scm_putc (' ', port);
if (SCM_NECONSP (exp))
break;
for (i = 0; i < pstate->top; ++i)
- if (pstate->ref_stack[i] == exp)
+ if (SCM_EQ_P (pstate->ref_stack[i], exp))
goto fancy_circref;
if (pstate->fancyp)
{
char *start;
char *p;
- if (SCM_BOOL_T == destination) {
- destination = scm_cur_outp;
- } else if (SCM_BOOL_F == 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);
- SCM_VALIDATE_LIST(3,args);
+ 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)
continue;
++p;
- if (*p == 'A')
+ 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 pwps;
SCM pair = scm_cons (port, pstate->handle);
- SCM_NEWSMOB (pwps, scm_tc16_port_with_ps, pair);
+ SCM_NEWSMOB (pwps, scm_tc16_port_with_ps, SCM_UNPACK (pair));
pstate->revealed = 1;
return scm_apply (proc, exp, scm_cons (pwps, scm_listofnull));
}
SCM_VALIDATE_OPORT_VALUE (1,port);
SCM_VALIDATE_PRINTSTATE (2,pstate);
port = SCM_COERCE_OUTPORT (port);
- SCM_NEWSMOB (pwps, scm_tc16_port_with_ps, scm_cons (port, pstate));
+ SCM_NEWSMOB (pwps, scm_tc16_port_with_ps, SCM_UNPACK (scm_cons (port, pstate)));
return pwps;
}
#undef FUNC_NAME
{
if (SCM_PORT_WITH_PS_P (port))
return SCM_PORT_WITH_PS_PS (port);
- if (SCM_OUTPORTP (port))
+ if (SCM_OUTPUT_PORT_P (port))
return SCM_BOOL_F;
RETURN_SCM_WTA (1,port);
}
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_smob_mark (scm_tc16_port_with_ps, scm_markcdr);
scm_set_smob_print (scm_tc16_port_with_ps, print_port_with_ps);
-#include "print.x"
+#include "libguile/print.x"
}
/*
HCoop / bpt / guile.git / blobdiff