165 |
|
|
166 |
SCM scm_print_state_vtable = SCM_BOOL_F; |
SCM scm_print_state_vtable = SCM_BOOL_F; |
167 |
static SCM print_state_pool = SCM_EOL; |
static SCM print_state_pool = SCM_EOL; |
168 |
|
SCM_MUTEX (print_state_mutex); |
169 |
|
|
170 |
#ifdef GUILE_DEBUG /* Used for debugging purposes */ |
#ifdef GUILE_DEBUG /* Used for debugging purposes */ |
171 |
|
|
205 |
SCM answer = SCM_BOOL_F; |
SCM answer = SCM_BOOL_F; |
206 |
|
|
207 |
/* First try to allocate a print state from the pool */ |
/* First try to allocate a print state from the pool */ |
208 |
SCM_DEFER_INTS; |
scm_i_plugin_mutex_lock (&print_state_mutex); |
209 |
if (!SCM_NULLP (print_state_pool)) |
if (!SCM_NULLP (print_state_pool)) |
210 |
{ |
{ |
211 |
answer = SCM_CAR (print_state_pool); |
answer = SCM_CAR (print_state_pool); |
212 |
print_state_pool = SCM_CDR (print_state_pool); |
print_state_pool = SCM_CDR (print_state_pool); |
213 |
} |
} |
214 |
SCM_ALLOW_INTS; |
scm_i_plugin_mutex_unlock (&print_state_mutex); |
215 |
|
|
216 |
return SCM_FALSEP (answer) ? make_print_state () : answer; |
return SCM_FALSEP (answer) ? make_print_state () : answer; |
217 |
} |
} |
228 |
*/ |
*/ |
229 |
pstate->fancyp = 0; |
pstate->fancyp = 0; |
230 |
pstate->revealed = 0; |
pstate->revealed = 0; |
231 |
SCM_DEFER_INTS; |
scm_i_plugin_mutex_lock (&print_state_mutex); |
232 |
handle = scm_cons (print_state, print_state_pool); |
handle = scm_cons (print_state, print_state_pool); |
233 |
print_state_pool = handle; |
print_state_pool = handle; |
234 |
SCM_ALLOW_INTS; |
scm_i_plugin_mutex_unlock (&print_state_mutex); |
235 |
|
} |
236 |
|
|
237 |
|
SCM |
238 |
|
scm_i_port_with_print_state (SCM port, SCM print_state) |
239 |
|
{ |
240 |
|
if (SCM_UNBNDP (print_state)) |
241 |
|
{ |
242 |
|
if (SCM_PORT_WITH_PS_P (port)) |
243 |
|
return port; |
244 |
|
else |
245 |
|
print_state = scm_make_print_state (); |
246 |
|
/* port does not need to be coerced since it doesn't have ps */ |
247 |
|
} |
248 |
|
else |
249 |
|
port = SCM_COERCE_OUTPORT (port); |
250 |
|
SCM_RETURN_NEWSMOB (scm_tc16_port_with_ps, |
251 |
|
SCM_UNPACK (scm_cons (port, print_state))); |
252 |
} |
} |
253 |
|
|
254 |
static void |
static void |
452 |
SCM pwps, print = pstate->writingp ? g_write : g_display; |
SCM pwps, print = pstate->writingp ? g_write : g_display; |
453 |
if (!print) |
if (!print) |
454 |
goto print_struct; |
goto print_struct; |
455 |
SCM_NEWSMOB (pwps, |
pwps = scm_i_port_with_print_state (port, pstate->handle); |
|
scm_tc16_port_with_ps, |
|
|
SCM_UNPACK (scm_cons (port, pstate->handle))); |
|
456 |
pstate->revealed = 1; |
pstate->revealed = 1; |
457 |
scm_call_generic_2 (print, exp, pwps); |
scm_call_generic_2 (print, exp, pwps); |
458 |
} |
} |
686 |
else |
else |
687 |
{ |
{ |
688 |
/* First try to allocate a print state from the pool */ |
/* First try to allocate a print state from the pool */ |
689 |
SCM_DEFER_INTS; |
scm_i_plugin_mutex_lock (&print_state_mutex); |
690 |
if (!SCM_NULLP (print_state_pool)) |
if (!SCM_NULLP (print_state_pool)) |
691 |
{ |
{ |
692 |
handle = print_state_pool; |
handle = print_state_pool; |
693 |
print_state_pool = SCM_CDR (print_state_pool); |
print_state_pool = SCM_CDR (print_state_pool); |
694 |
} |
} |
695 |
SCM_ALLOW_INTS; |
scm_i_plugin_mutex_unlock (&print_state_mutex); |
696 |
if (SCM_FALSEP (handle)) |
if (SCM_FALSEP (handle)) |
697 |
handle = scm_list_1 (make_print_state ()); |
handle = scm_list_1 (make_print_state ()); |
698 |
pstate_scm = SCM_CAR (handle); |
pstate_scm = SCM_CAR (handle); |
709 |
|
|
710 |
if (!SCM_FALSEP (handle) && !pstate->revealed) |
if (!SCM_FALSEP (handle) && !pstate->revealed) |
711 |
{ |
{ |
712 |
SCM_DEFER_INTS; |
scm_i_plugin_mutex_lock (&print_state_mutex); |
713 |
SCM_SETCDR (handle, print_state_pool); |
SCM_SETCDR (handle, print_state_pool); |
714 |
print_state_pool = handle; |
print_state_pool = handle; |
715 |
SCM_ALLOW_INTS; |
scm_i_plugin_mutex_unlock (&print_state_mutex); |
716 |
} |
} |
717 |
} |
} |
718 |
|
|
916 |
"containing the formatted text. Does not add a trailing newline.") |
"containing the formatted text. Does not add a trailing newline.") |
917 |
#define FUNC_NAME s_scm_simple_format |
#define FUNC_NAME s_scm_simple_format |
918 |
{ |
{ |
919 |
SCM answer = SCM_UNSPECIFIED; |
SCM port, answer = SCM_UNSPECIFIED; |
920 |
int fReturnString = 0; |
int fReturnString = 0; |
921 |
int writingp; |
int writingp; |
922 |
char *start; |
char *start; |
925 |
|
|
926 |
if (SCM_EQ_P (destination, SCM_BOOL_T)) |
if (SCM_EQ_P (destination, SCM_BOOL_T)) |
927 |
{ |
{ |
928 |
destination = scm_cur_outp; |
destination = port = scm_cur_outp; |
929 |
} |
} |
930 |
else if (SCM_FALSEP (destination)) |
else if (SCM_FALSEP (destination)) |
931 |
{ |
{ |
932 |
fReturnString = 1; |
fReturnString = 1; |
933 |
destination = scm_mkstrport (SCM_INUM0, |
port = scm_mkstrport (SCM_INUM0, |
934 |
scm_make_string (SCM_INUM0, SCM_UNDEFINED), |
scm_make_string (SCM_INUM0, SCM_UNDEFINED), |
935 |
SCM_OPN | SCM_WRTNG, |
SCM_OPN | SCM_WRTNG, |
936 |
FUNC_NAME); |
FUNC_NAME); |
937 |
|
destination = port; |
938 |
} |
} |
939 |
else |
else |
940 |
{ |
{ |
941 |
SCM_VALIDATE_OPORT_VALUE (1, destination); |
SCM_VALIDATE_OPORT_VALUE (1, destination); |
942 |
destination = SCM_COERCE_OUTPORT (destination); |
port = SCM_COERCE_OUTPORT (destination); |
943 |
} |
} |
944 |
SCM_VALIDATE_STRING (2, message); |
SCM_VALIDATE_STRING (2, message); |
945 |
SCM_VALIDATE_REST_ARGUMENT (args); |
SCM_VALIDATE_REST_ARGUMENT (args); |
961 |
writingp = 1; |
writingp = 1; |
962 |
break; |
break; |
963 |
case '~': |
case '~': |
964 |
scm_lfwrite (start, p - start, destination); |
scm_lfwrite (start, p - start, port); |
965 |
start = p + 1; |
start = p + 1; |
966 |
continue; |
continue; |
967 |
case '%': |
case '%': |
968 |
scm_lfwrite (start, p - start - 1, destination); |
scm_lfwrite (start, p - start - 1, port); |
969 |
scm_newline (destination); |
scm_newline (port); |
970 |
start = p + 1; |
start = p + 1; |
971 |
continue; |
continue; |
972 |
default: |
default: |
980 |
SCM_MISC_ERROR ("FORMAT: Missing argument for ~~~A", |
SCM_MISC_ERROR ("FORMAT: Missing argument for ~~~A", |
981 |
scm_list_1 (SCM_MAKE_CHAR (*p))); |
scm_list_1 (SCM_MAKE_CHAR (*p))); |
982 |
|
|
983 |
scm_lfwrite (start, p - start - 1, destination); |
scm_lfwrite (start, p - start - 1, port); |
984 |
|
/* we pass destination here */ |
985 |
scm_prin1 (SCM_CAR (args), destination, writingp); |
scm_prin1 (SCM_CAR (args), destination, writingp); |
986 |
args = SCM_CDR (args); |
args = SCM_CDR (args); |
987 |
start = p + 1; |
start = p + 1; |
988 |
} |
} |
989 |
|
|
990 |
scm_lfwrite (start, p - start, destination); |
scm_lfwrite (start, p - start, port); |
991 |
if (!SCM_EQ_P (args, SCM_EOL)) |
if (!SCM_EQ_P (args, SCM_EOL)) |
992 |
SCM_MISC_ERROR ("FORMAT: ~A superfluous arguments", |
SCM_MISC_ERROR ("FORMAT: ~A superfluous arguments", |
993 |
scm_list_1 (scm_length (args))); |
scm_list_1 (scm_length (args))); |
1062 |
SCM |
SCM |
1063 |
scm_printer_apply (SCM proc, SCM exp, SCM port, scm_print_state *pstate) |
scm_printer_apply (SCM proc, SCM exp, SCM port, scm_print_state *pstate) |
1064 |
{ |
{ |
|
SCM pwps; |
|
|
SCM pair = scm_cons (port, pstate->handle); |
|
|
SCM_NEWSMOB (pwps, scm_tc16_port_with_ps, SCM_UNPACK (pair)); |
|
1065 |
pstate->revealed = 1; |
pstate->revealed = 1; |
1066 |
return scm_call_2 (proc, exp, pwps); |
return scm_call_2 (proc, exp, |
1067 |
|
scm_i_port_with_print_state (port, pstate->handle)); |
1068 |
} |
} |
1069 |
|
|
1070 |
SCM_DEFINE (scm_port_with_print_state, "port-with-print-state", 2, 0, 0, |
SCM_DEFINE (scm_port_with_print_state, "port-with-print-state", 1, 1, 0, |
1071 |
(SCM port, SCM pstate), |
(SCM port, SCM pstate), |
1072 |
"Create a new port which behaves like @var{port}, but with an\n" |
"Create a new port which behaves like @var{port}, but with an\n" |
1073 |
"included print state @var{pstate}.") |
"included print state @var{pstate}. @var{pstate} is optional.\n" |
1074 |
|
"If @var{pstate} isn't supplied and @var{port} already has\n" |
1075 |
|
"a print state, the old print state is reused.") |
1076 |
#define FUNC_NAME s_scm_port_with_print_state |
#define FUNC_NAME s_scm_port_with_print_state |
1077 |
{ |
{ |
|
SCM pwps; |
|
1078 |
SCM_VALIDATE_OPORT_VALUE (1, port); |
SCM_VALIDATE_OPORT_VALUE (1, port); |
1079 |
SCM_VALIDATE_PRINTSTATE (2, pstate); |
if (!SCM_UNBNDP (pstate)) |
1080 |
port = SCM_COERCE_OUTPORT (port); |
SCM_VALIDATE_PRINTSTATE (2, pstate); |
1081 |
SCM_NEWSMOB (pwps, scm_tc16_port_with_ps, SCM_UNPACK (scm_cons (port, pstate))); |
return scm_i_port_with_print_state (port, pstate); |
|
return pwps; |
|
1082 |
} |
} |
1083 |
#undef FUNC_NAME |
#undef FUNC_NAME |
1084 |
|
|